DriverPipeline.hs 97 KB
Newer Older
Ben Gamari's avatar
Ben Gamari committed
1
{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}
2
{-# OPTIONS_GHC -fno-cse #-}
3 4
-- -fno-cse is needed for GLOBAL_VAR's to behave properly

5 6 7 8
-----------------------------------------------------------------------------
--
-- GHC Driver
--
9
-- (c) The University of Glasgow 2005
10 11 12 13
--
-----------------------------------------------------------------------------

module DriverPipeline (
Ian Lynagh's avatar
Ian Lynagh committed
14 15
        -- Run a series of compilation steps in a pipeline, for a
        -- collection of source files.
16
   oneShot, compileFile,
17

Ian Lynagh's avatar
Ian Lynagh committed
18
        -- Interfaces for the batch-mode driver
19
   linkBinary,
20

Ian Lynagh's avatar
Ian Lynagh committed
21 22
        -- Interfaces for the compilation manager (interpreted/batch-mode)
   preprocess,
23
   compileOne, compileOne',
Ian Lynagh's avatar
Ian Lynagh committed
24
   link,
25

26 27
        -- Exports for hooks to override runPhase and link
   PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),
28
   phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,
29 30
   hscPostBackendPhase, getLocation, setModLocation, setDynFlags,
   runPhase, exeFileName,
thomie's avatar
thomie committed
31
   maybeCreateManifest,
32
   linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode
33 34 35 36
  ) where

#include "HsVersions.h"

37 38
import GhcPrelude

39
import PipelineMonad
40
import Packages
41
import HeaderInfo
42
import DriverPhases
43
import SysTools
Tamar Christina's avatar
Tamar Christina committed
44
import SysTools.ExtraObj
45
import HscMain
46
import Finder
47
import HscTypes hiding ( Hsc )
48 49
import Outputable
import Module
50
import ErrUtils
51
import DynFlags
52
import Config
53
import Panic
54
import Util
Ian Lynagh's avatar
Ian Lynagh committed
55 56 57
import StringBuffer     ( hGetStringBuffer )
import BasicTypes       ( SuccessFlag(..) )
import Maybes           ( expectJust )
58
import SrcLoc
59
import LlvmCodeGen      ( llvmFixupAsm )
60
import MonadUtils
61
import Platform
62
import TcRnTypes
63
import Hooks
64
import qualified GHC.LanguageExtensions as LangExt
Douglas Wilson's avatar
Douglas Wilson committed
65
import FileCleanup
Moritz Angermann's avatar
Moritz Angermann committed
66
import Ar
67

68
import Exception
Simon Marlow's avatar
Simon Marlow committed
69
import System.Directory
Ian Lynagh's avatar
Ian Lynagh committed
70
import System.FilePath
Simon Marlow's avatar
Simon Marlow committed
71 72
import System.IO
import Control.Monad
Ben Gamari's avatar
Ben Gamari committed
73
import Data.List        ( isInfixOf, intercalate )
Simon Marlow's avatar
Simon Marlow committed
74
import Data.Maybe
75
import Data.Version
76
import Data.Either      ( partitionEithers )
77

Alec Theriault's avatar
Alec Theriault committed
78 79
import Data.Time        ( UTCTime )

80 81
-- ---------------------------------------------------------------------------
-- Pre-process
82

83
-- | Just preprocess a file, put the result in a temp. file (used by the
84
-- compilation manager during the summary phase).
85 86 87
--
-- We return the augmented DynFlags, because they contain the result
-- of slurping in the OPTIONS pragmas
88

89
preprocess :: HscEnv
90
           -> (FilePath, Maybe Phase) -- ^ filename and starting phase
91
           -> IO (DynFlags, FilePath)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
92
preprocess hsc_env (filename, mb_phase) =
Ian Lynagh's avatar
Ian Lynagh committed
93
  ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
94
  runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase)
Douglas Wilson's avatar
Douglas Wilson committed
95 96 97 98 99 100
        Nothing
        -- We keep the processed file for the whole session to save on
        -- duplicated work in ghci.
        (Temporary TFL_GhcSession)
        Nothing{-no ModLocation-}
        []{-no foreign objects-}
101

102
-- ---------------------------------------------------------------------------
103

104 105
-- | Compile
--
106 107 108 109
-- Compile a single module, under the control of the compilation manager.
--
-- This is the interface between the compilation manager and the
-- compiler proper (hsc), where we deal with tedious details like
110 111 112
-- reading the OPTIONS pragma from the source file, converting the
-- C or assembly that GHC produces into an object file, and compiling
-- FFI stub files.
113
--
114 115
-- NB.  No old interface can also mean that the source has changed.

116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140
compileOne :: HscEnv
           -> ModSummary      -- ^ summary for module being compiled
           -> Int             -- ^ module N ...
           -> Int             -- ^ ... of M
           -> Maybe ModIface  -- ^ old interface, if we have one
           -> Maybe Linkable  -- ^ old linkable, if we have one
           -> SourceModified
           -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful

compileOne = compileOne' Nothing (Just batchMsg)

compileOne' :: Maybe TcGblEnv
            -> Maybe Messager
            -> HscEnv
            -> ModSummary      -- ^ summary for module being compiled
            -> Int             -- ^ module N ...
            -> Int             -- ^ ... of M
            -> Maybe ModIface  -- ^ old interface, if we have one
            -> Maybe Linkable  -- ^ old linkable, if we have one
            -> SourceModified
            -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful

compileOne' m_tc_result mHscMessage
            hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
            source_modified0
141
 = do
142

143
   debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)
144

145 146 147 148 149
   (status, hmi0) <- hscIncrementalCompile
                        always_do_basic_recompilation_check
                        m_tc_result mHscMessage
                        hsc_env summary source_modified mb_old_iface (mod_index, nmods)

150 151
   let flags = hsc_dflags hsc_env0
     in do unless (gopt Opt_KeepHiFiles flags) $
Douglas Wilson's avatar
Douglas Wilson committed
152 153
               addFilesToClean flags TFL_CurrentModule $
                   [ml_hi_file $ ms_location summary]
154
           unless (gopt Opt_KeepOFiles flags) $
Douglas Wilson's avatar
Douglas Wilson committed
155 156
               addFilesToClean flags TFL_GhcSession $
                   [ml_obj_file $ ms_location summary]
157

158 159
   case (status, hsc_lang) of
        (HscUpToDate, _) ->
Edward Z. Yang's avatar
Edward Z. Yang committed
160 161
            -- TODO recomp014 triggers this assert. What's going on?!
            -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )
162 163
            return hmi0 { hm_linkable = maybe_old_linkable }
        (HscNotGeneratingCode, HscNothing) ->
164
            let mb_linkable = if isHsBootOrSig src_flavour
165 166 167 168 169 170 171 172 173 174 175
                                then Nothing
                                -- TODO: Questionable.
                                else Just (LM (ms_hs_date summary) this_mod [])
            in return hmi0 { hm_linkable = mb_linkable }
        (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode"
        (_, HscNothing) -> panic "compileOne HscNothing"
        (HscUpdateBoot, HscInterpreted) -> do
            return hmi0
        (HscUpdateBoot, _) -> do
            touchObjectFile dflags object_filename
            return hmi0
176
        (HscUpdateSig, HscInterpreted) ->
177 178
            let linkable = LM (ms_hs_date summary) this_mod []
            in return hmi0 { hm_linkable = Just linkable }
179
        (HscUpdateSig, _) -> do
180
            output_fn <- getOutputFilename next_phase
Douglas Wilson's avatar
Douglas Wilson committed
181 182
                            (Temporary TFL_CurrentModule) basename dflags
                            next_phase (Just location)
183 184 185 186 187 188 189

            -- #10660: Use the pipeline instead of calling
            -- compileEmptyStub directly, so -dynamic-too gets
            -- handled properly
            _ <- runPipeline StopLn hsc_env
                              (output_fn,
                               Just (HscOut src_flavour
190
                                            mod_name HscUpdateSig))
191 192 193
                              (Just basename)
                              Persistent
                              (Just location)
194
                              []
195 196 197 198
            o_time <- getModificationUTCTime object_filename
            let linkable = LM o_time this_mod [DotO object_filename]
            return hmi0 { hm_linkable = Just linkable }
        (HscRecomp cgguts summary, HscInterpreted) -> do
199 200
            (hasStub, comp_bc, spt_entries) <-
                hscInteractive hsc_env cgguts summary
201 202 203 204 205 206 207

            stub_o <- case hasStub of
                      Nothing -> return []
                      Just stub_c -> do
                          stub_o <- compileStub hsc_env stub_c
                          return [DotO stub_o]

208
            let hs_unlinked = [BCOs comp_bc spt_entries]
209 210 211 212 213 214 215 216 217 218 219 220
                unlinked_time = ms_hs_date summary
              -- Why do we use the timestamp of the source file here,
              -- rather than the current time?  This works better in
              -- the case where the local clock is out of sync
              -- with the filesystem's clock.  It's just as accurate:
              -- if the source is modified, then the linkable will
              -- be out of date.
            let linkable = LM unlinked_time (ms_mod summary)
                           (hs_unlinked ++ stub_o)
            return hmi0 { hm_linkable = Just linkable }
        (HscRecomp cgguts summary, _) -> do
            output_fn <- getOutputFilename next_phase
Douglas Wilson's avatar
Douglas Wilson committed
221 222
                            (Temporary TFL_CurrentModule)
                            basename dflags next_phase (Just location)
223 224 225 226 227 228 229
            -- We're in --make mode: finish the compilation pipeline.
            _ <- runPipeline StopLn hsc_env
                              (output_fn,
                               Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))
                              (Just basename)
                              Persistent
                              (Just location)
230
                              []
231 232 233 234 235
                  -- The object filename comes from the ModLocation
            o_time <- getModificationUTCTime object_filename
            let linkable = LM o_time this_mod [DotO object_filename]
            return hmi0 { hm_linkable = Just linkable }

236
 where dflags0     = ms_hspp_opts summary
Edward Z. Yang's avatar
Edward Z. Yang committed
237 238

       this_mod    = ms_mod summary
239 240
       location    = ms_location summary
       input_fn    = expectJust "compile:hs" (ml_hs_file location)
Edward Z. Yang's avatar
Edward Z. Yang committed
241
       input_fnpp  = ms_hspp_file summary
242
       mod_graph   = hsc_mod_graph hsc_env0
243
       needsLinker = needsTemplateHaskellOrQQ mod_graph
244 245
       isDynWay    = any (== WayDyn) (ways dflags0)
       isProfWay   = any (== WayProf) (ways dflags0)
246
       internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0)
247 248 249

       src_flavour = ms_hsc_src summary
       mod_name = ms_mod_name summary
Ben Gamari's avatar
Ben Gamari committed
250
       next_phase = hscPostBackendPhase src_flavour hsc_lang
251 252
       object_filename = ml_obj_file location

253
       -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
254 255
       -- the linker can correctly load the object files.  This isn't necessary
       -- when using -fexternal-interpreter.
Douglas Wilson's avatar
Douglas Wilson committed
256 257
       dflags1 = if dynamicGhc && internalInterpreter &&
                    not isDynWay && not isProfWay && needsLinker
258 259 260 261 262 263 264 265 266 267
                  then gopt_set dflags0 Opt_BuildDynamicToo
                  else dflags0

       basename = dropExtension input_fn

       -- We add the directory in which the .hs files resides) to the import
       -- path.  This is needed when we try to compile the .hc file later, if it
       -- imports a _stub.h file that we created here.
       current_dir = takeDirectory basename
       old_paths   = includePaths dflags1
Simon Marlow's avatar
Simon Marlow committed
268
       !prevailing_dflags = hsc_dflags hsc_env0
269
       dflags =
270
          dflags1 { includePaths = addQuoteInclude old_paths [current_dir]
271
                  , log_action = log_action prevailing_dflags }
272 273 274 275
                  -- use the prevailing log_action / log_finaliser,
                  -- not the one cached in the summary.  This is so
                  -- that we can change the log_action without having
                  -- to re-summarize all the source files.
276 277 278 279 280 281 282 283 284 285 286 287 288 289
       hsc_env     = hsc_env0 {hsc_dflags = dflags}

       -- Figure out what lang we're generating
       hsc_lang = hscTarget dflags

       -- -fforce-recomp should also work with --make
       force_recomp = gopt Opt_ForceRecomp dflags
       source_modified
         | force_recomp = SourceModified
         | otherwise = source_modified0

       always_do_basic_recompilation_check = case hsc_lang of
                                             HscInterpreted -> True
                                             _ -> False
290

291
-----------------------------------------------------------------------------
292
-- stub .h and .c files (for foreign export support), and cc files.
293

294 295 296
-- The _stub.c file is derived from the haskell source file, possibly taking
-- into account the -stubdir option.
--
297 298
-- The object file created by compiling the _stub.c file is put into a
-- temporary file, which will be later combined with the main .o file
299 300 301 302 303 304 305
-- (see the MergeForeigns phase).
--
-- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files
-- from TH, that are then compiled and linked to the module. This is
-- useful to implement facilities such as inline-c.

compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
306
compileForeign _ RawObject object_file = return object_file
307 308
compileForeign hsc_env lang stub_c = do
        let phase = case lang of
309 310 311
              LangC      -> Cc
              LangCxx    -> Ccxx
              LangObjc   -> Cobjc
312
              LangObjcxx -> Cobjcxx
313 314
              LangAsm    -> As True -- allow CPP
              RawObject  -> panic "compileForeign: should be unreachable"
315 316
        (_, stub_o) <- runPipeline StopLn hsc_env
                       (stub_c, Just (RealPhase phase))
Douglas Wilson's avatar
Douglas Wilson committed
317 318 319
                       Nothing (Temporary TFL_GhcSession)
                       Nothing{-no ModLocation-}
                       []
Ian Lynagh's avatar
Ian Lynagh committed
320
        return stub_o
321

322 323 324
compileStub :: HscEnv -> FilePath -> IO FilePath
compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c

325 326
compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
compileEmptyStub dflags hsc_env basename location mod_name = do
327 328
  -- To maintain the invariant that every Haskell file
  -- compiles to object code, we make an empty (but
329 330 331
  -- valid) stub object file for signatures.  However,
  -- we make sure this object file has a unique symbol,
  -- so that ranlib on OS X doesn't complain, see
332
  -- https://gitlab.haskell.org/ghc/ghc/issues/12673
333
  -- and https://github.com/haskell/cabal/issues/2257
Douglas Wilson's avatar
Douglas Wilson committed
334
  empty_stub <- newTempName dflags TFL_CurrentModule "c"
335 336
  let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;"
  writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
337 338 339 340 341
  _ <- runPipeline StopLn hsc_env
                  (empty_stub, Nothing)
                  (Just basename)
                  Persistent
                  (Just location)
342
                  []
343 344
  return ()

345 346
-- ---------------------------------------------------------------------------
-- Link
347

Ian Lynagh's avatar
Ian Lynagh committed
348 349 350 351
link :: GhcLink                 -- interactive or batch
     -> DynFlags                -- dynamic flags
     -> Bool                    -- attempt linking in batch mode?
     -> HomePackageTable        -- what to link
352 353 354 355 356 357 358 359 360
     -> IO SuccessFlag

-- For the moment, in the batch linker, we don't bother to tell doLink
-- which packages to link -- it just tries all that are available.
-- batch_attempt_linking should only be *looked at* in batch mode.  It
-- should only be True if the upsweep was successful and someone
-- exports main, i.e., we have good reason to believe that linking
-- will succeed.

361 362 363 364 365 366 367 368
link ghcLink dflags
  = lookupHook linkHook l dflags ghcLink dflags
  where
    l LinkInMemory _ _ _
      = if cGhcWithInterpreter == "YES"
        then -- Not Linking...(demand linker will do the job)
             return Succeeded
        else panicBadLink LinkInMemory
369

370 371
    l NoLink _ _ _
      = return Succeeded
372

373 374
    l LinkBinary dflags batch_attempt_linking hpt
      = link' dflags batch_attempt_linking hpt
375

376 377
    l LinkStaticLib dflags batch_attempt_linking hpt
      = link' dflags batch_attempt_linking hpt
378

379 380
    l LinkDynLib dflags batch_attempt_linking hpt
      = link' dflags batch_attempt_linking hpt
381 382 383 384 385 386 387 388 389 390 391

panicBadLink :: GhcLink -> a
panicBadLink other = panic ("link: GHC not built to link this way: " ++
                            show other)

link' :: DynFlags                -- dynamic flags
      -> Bool                    -- attempt linking in batch mode?
      -> HomePackageTable        -- what to link
      -> IO SuccessFlag

link' dflags batch_attempt_linking hpt
392
   | batch_attempt_linking
Ian Lynagh's avatar
Ian Lynagh committed
393 394
   = do
        let
395 396
            staticLink = case ghcLink dflags of
                          LinkStaticLib -> True
397
                          _ -> False
398

niteria's avatar
niteria committed
399
            home_mod_infos = eltsHpt hpt
400

Ian Lynagh's avatar
Ian Lynagh committed
401
            -- the packages we depend on
402
            pkg_deps  = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos
403

Ian Lynagh's avatar
Ian Lynagh committed
404 405
            -- the linkables to link
            linkables = map (expectJust "link".hm_linkable) home_mod_infos
406

407
        debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
408

Ian Lynagh's avatar
Ian Lynagh committed
409 410 411 412 413
        -- check for the -no-link flag
        if isNoLink (ghcLink dflags)
          then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).")
                  return Succeeded
          else do
414

Ian Lynagh's avatar
Ian Lynagh committed
415 416
        let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
            obj_files = concatMap getOfiles linkables
417

418
            exe_file = exeFileName staticLink dflags
419

420
        linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps
421

ian@well-typed.com's avatar
ian@well-typed.com committed
422
        if not (gopt Opt_ForceRecomp dflags) && not linking_needed
423
           then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.")
Ian Lynagh's avatar
Ian Lynagh committed
424 425
                   return Succeeded
           else do
426

Ian Lynagh's avatar
Ian Lynagh committed
427
        compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...")
428

Ian Lynagh's avatar
Ian Lynagh committed
429 430
        -- Don't showPass in Batch mode; doLink will do that for us.
        let link = case ghcLink dflags of
431
                LinkBinary    -> linkBinary
Moritz Angermann's avatar
Moritz Angermann committed
432
                LinkStaticLib -> linkStaticLib
433 434
                LinkDynLib    -> linkDynLibCheck
                other         -> panicBadLink other
Ian Lynagh's avatar
Ian Lynagh committed
435
        link dflags obj_files pkg_deps
436

437
        debugTraceMsg dflags 3 (text "link: done")
438

Ian Lynagh's avatar
Ian Lynagh committed
439
        -- linkBinary only returns if it succeeds
440 441 442
        return Succeeded

   | otherwise
443 444
   = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$
                                text "   Main.main not exported; not linking.")
445
        return Succeeded
Ian Lynagh's avatar
Ian Lynagh committed
446

447

448
linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool
449
linkingNeeded dflags staticLink linkables pkg_deps = do
450 451 452
        -- if the modification time on the executable is later than the
        -- modification times on all of the objects and libraries, then omit
        -- linking (unless the -fforce-recomp flag was given).
453
  let exe_file = exeFileName staticLink dflags
454
  e_exe_time <- tryIO $ getModificationUTCTime exe_file
455 456 457 458
  case e_exe_time of
    Left _  -> return True
    Right t -> do
        -- first check object files and extra_ld_inputs
459
        let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
460
        e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs
461
        let (errs,extra_times) = partitionEithers e_extra_times
462 463
        let obj_times =  map linkableTime linkables ++ extra_times
        if not (null errs) || any (t <) obj_times
Ian Lynagh's avatar
Ian Lynagh committed
464
            then return True
465 466 467 468
            else do

        -- next, check libraries. XXX this only checks Haskell libraries,
        -- not extra_libraries or -l things from the command line.
469
        let pkg_hslibs  = [ (collectLibraryPaths dflags [c], lib)
470
                          | Just c <- map (lookupInstalledPackage dflags) pkg_deps,
471 472
                            lib <- packageHsLibs dflags c ]

473
        pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs
474
        if any isNothing pkg_libfiles then return True else do
475
        e_lib_times <- mapM (tryIO . getModificationUTCTime)
476
                          (catMaybes pkg_libfiles)
477
        let (lib_errs,lib_times) = partitionEithers e_lib_times
478 479
        if not (null lib_errs) || any (t <) lib_times
           then return True
480 481
           else checkLinkInfo dflags pkg_deps exe_file

482 483
findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath)
findHSLib dflags dirs lib = do
thomie's avatar
thomie committed
484
  let batch_lib_file = if WayDyn `notElem` ways dflags
Tamar Christina's avatar
Tamar Christina committed
485 486
                      then "lib" ++ lib <.> "a"
                      else mkSOName (targetPlatform dflags) lib
487 488 489 490 491
  found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
  case found of
    [] -> return Nothing
    (x:_) -> return (Just x)

492 493 494
-- -----------------------------------------------------------------------------
-- Compile files in one-shot mode.

495
oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
496 497
oneShot hsc_env stop_phase srcs = do
  o_files <- mapM (compileFile hsc_env stop_phase) srcs
498
  doLink (hsc_dflags hsc_env) stop_phase o_files
499

500
compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
501
compileFile hsc_env stop_phase (src, mb_phase) = do
502
   exists <- doesFileExist src
Ian Lynagh's avatar
Ian Lynagh committed
503
   when (not exists) $
504
        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))
Ian Lynagh's avatar
Ian Lynagh committed
505

506
   let
Austin Seipp's avatar
Austin Seipp committed
507
        dflags    = hsc_dflags hsc_env
Ian Lynagh's avatar
Ian Lynagh committed
508 509
        mb_o_file = outputFile dflags
        ghc_link  = ghcLink dflags      -- Set by -c or -no-link
510

Ian Lynagh's avatar
Ian Lynagh committed
511 512
        -- When linking, the -o argument refers to the linker's output.
        -- otherwise, we use it as the name for the pipeline's output.
513
        output
Douglas Wilson's avatar
Douglas Wilson committed
514
         -- If we are doing -fno-code, then act as if the output is
515 516
         -- 'Temporary'. This stops GHC trying to copy files to their
         -- final location.
Douglas Wilson's avatar
Douglas Wilson committed
517
         | HscNothing <- hscTarget dflags = Temporary TFL_CurrentModule
Ian Lynagh's avatar
Ian Lynagh committed
518 519
         | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
                -- -o foo applies to linker
520
         | isJust mb_o_file = SpecificFile
Ian Lynagh's avatar
Ian Lynagh committed
521 522 523
                -- -o foo applies to the file we are compiling now
         | otherwise = Persistent

Ben Gamari's avatar
Ben Gamari committed
524
   ( _, out_file) <- runPipeline stop_phase hsc_env
525
                            (src, fmap RealPhase mb_phase) Nothing output
526
                            Nothing{-no ModLocation-} []
527 528 529 530 531 532
   return out_file


doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
doLink dflags stop_phase o_files
  | not (isStopLn stop_phase)
Ian Lynagh's avatar
Ian Lynagh committed
533
  = return ()           -- We stopped before the linking phase
534 535 536

  | otherwise
  = case ghcLink dflags of
537 538
        NoLink        -> return ()
        LinkBinary    -> linkBinary         dflags o_files []
Moritz Angermann's avatar
Moritz Angermann committed
539
        LinkStaticLib -> linkStaticLib      dflags o_files []
540 541
        LinkDynLib    -> linkDynLibCheck    dflags o_files []
        other         -> panicBadLink other
542 543


544
-- ---------------------------------------------------------------------------
545

546 547 548 549 550 551 552
-- | Run a compilation pipeline, consisting of multiple phases.
--
-- This is the interface to the compilation pipeline, which runs
-- a series of compilation steps on a single source file, specifying
-- at which stage to stop.
--
-- The DynFlags can be modified by phases in the pipeline (eg. by
Ian Lynagh's avatar
Ian Lynagh committed
553
-- OPTIONS_GHC pragmas), and the changes affect later phases in the
554
-- pipeline.
555
runPipeline
556
  :: Phase                      -- ^ When to stop
557
  -> HscEnv                     -- ^ Compilation environment
558
  -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix)
559
  -> Maybe FilePath             -- ^ original basename (if different from ^^^)
Ian Lynagh's avatar
Ian Lynagh committed
560
  -> PipelineOutput             -- ^ Output filename
561
  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
562
  -> [FilePath]                 -- ^ foreign objects
563
  -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)
564
runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
565
             mb_basename output maybe_loc foreign_os
566 567 568 569 570 571 572 573 574 575 576 577 578

    = do let
             dflags0 = hsc_dflags hsc_env0

             -- Decide where dump files should go based on the pipeline output
             dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
             hsc_env = hsc_env0 {hsc_dflags = dflags}

             (input_basename, suffix) = splitExtension input_fn
             suffix' = drop 1 suffix -- strip off the .
             basename | Just b <- mb_basename = b
                      | otherwise             = input_basename

ian@well-typed.com's avatar
ian@well-typed.com committed
579
             -- If we were given a -x flag, then use that phase to start from
580
             start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase
ian@well-typed.com's avatar
ian@well-typed.com committed
581

582 583 584 585 586 587
             isHaskell (RealPhase (Unlit _)) = True
             isHaskell (RealPhase (Cpp   _)) = True
             isHaskell (RealPhase (HsPp  _)) = True
             isHaskell (RealPhase (Hsc   _)) = True
             isHaskell (HscOut {})           = True
             isHaskell _                     = False
ian@well-typed.com's avatar
ian@well-typed.com committed
588 589 590

             isHaskellishFile = isHaskell start_phase

591
             env = PipeEnv{ stop_phase,
592
                            src_filename = input_fn,
593 594 595 596
                            src_basename = basename,
                            src_suffix = suffix',
                            output_spec = output }

597 598 599 600
         when (isBackpackishSuffix suffix') $
           throwGhcExceptionIO (UsageError
                       ("use --backpack to process " ++ input_fn))

601 602 603
         -- We want to catch cases of "you can't get there from here" before
         -- we start the pipeline, because otherwise it will just run off the
         -- end.
604
         let happensBefore' = happensBefore dflags
605 606
         case start_phase of
             RealPhase start_phase' ->
607 608 609 610
                 -- See Note [Partial ordering on phases]
                 -- Not the same as: (stop_phase `happensBefore` start_phase')
                 when (not (start_phase' `happensBefore'` stop_phase ||
                            start_phase' `eqPhase` stop_phase)) $
611 612 613 614
                       throwGhcExceptionIO (UsageError
                                   ("cannot compile this file to desired target: "
                                      ++ input_fn))
             HscOut {} -> return ()
615

ian@well-typed.com's avatar
ian@well-typed.com committed
616
         debugTraceMsg dflags 4 (text "Running the pipeline")
617
         r <- runPipeline' start_phase hsc_env env input_fn
618
                           maybe_loc foreign_os
ian@well-typed.com's avatar
ian@well-typed.com committed
619 620 621 622

         -- If we are compiling a Haskell module, and doing
         -- -dynamic-too, but couldn't do the -dynamic-too fast
         -- path, then rerun the pipeline for the dyn way
623
         let dflags = hsc_dflags hsc_env
Austin Seipp's avatar
Austin Seipp committed
624 625 626 627 628 629 630 631
         -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)
         when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do
           when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do
               debugTraceMsg dflags 4
                   (text "Running the pipeline again for -dynamic-too")
               let dflags' = dynamicTooMkDynamicDynFlags dflags
               hsc_env' <- newHscEnv dflags'
               _ <- runPipeline' start_phase hsc_env' env input_fn
632
                                 maybe_loc foreign_os
Austin Seipp's avatar
Austin Seipp committed
633
               return ()
634 635 636
         return r

runPipeline'
637
  :: PhasePlus                  -- ^ When to start
638
  -> HscEnv                     -- ^ Compilation environment
639 640
  -> PipeEnv
  -> FilePath                   -- ^ Input filename
641
  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
642
  -> [FilePath]                 -- ^ foreign objects, if we have one
643
  -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)
644
runPipeline' start_phase hsc_env env input_fn
645
             maybe_loc foreign_os
646
  = do
647
  -- Execute the pipeline...
648
  let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os }
649

650
  evalP (pipeLoop start_phase input_fn) env state
651

652 653 654 655
-- ---------------------------------------------------------------------------
-- outer pipeline loop

-- | pipeLoop runs phases until we reach the stop phase
656
pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
657
pipeLoop phase input_fn = do
658
  env <- getPipeEnv
659
  dflags <- getDynFlags
660
  -- See Note [Partial ordering on phases]
661
  let happensBefore' = happensBefore dflags
662
      stopPhase = stop_phase env
663 664
  case phase of
   RealPhase realPhase | realPhase `eqPhase` stopPhase            -- All done
665 666 667 668 669 670
     -> -- Sometimes, a compilation phase doesn't actually generate any output
        -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
        -- stage, but we wanted to keep the output, then we have to explicitly
        -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
        -- further compilation stages can tell what the original filename was.
        case output_spec env of
Douglas Wilson's avatar
Douglas Wilson committed
671
        Temporary _ ->
672 673 674 675 676 677 678 679 680 681 682 683 684
            return (dflags, input_fn)
        output ->
            do pst <- getPipeState
               final_fn <- liftIO $ getOutputFilename
                                        stopPhase output (src_basename env)
                                        dflags stopPhase (maybe_loc pst)
               when (final_fn /= input_fn) $ do
                  let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")
                      line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")
                  liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn
               return (dflags, final_fn)


685
     | not (realPhase `happensBefore'` stopPhase)
Ian Lynagh's avatar
Ian Lynagh committed
686 687 688 689
        -- Something has gone wrong.  We'll try to cover all the cases when
        -- this could happen, so if we reach here it is a panic.
        -- eg. it might happen if the -C flag is used on a source file that
        -- has {-# OPTIONS -fasm #-}.
690
     -> panic ("pipeLoop: at phase " ++ show realPhase ++
691
           " but I wanted to stop at phase " ++ show stopPhase)
Ian Lynagh's avatar
Ian Lynagh committed
692

693
   _
694
     -> do liftIO $ debugTraceMsg dflags 4
695
                                  (text "Running phase" <+> ppr phase)
696
           (next_phase, output_fn) <- runHookedPhase phase input_fn dflags
697
           r <- pipeLoop next_phase output_fn
698
           case phase of
699 700
               HscOut {} ->
                   whenGeneratingDynamicToo dflags $ do
701
                       setDynFlags $ dynamicTooMkDynamicDynFlags dflags
702
                       -- TODO shouldn't ignore result:
703
                       _ <- pipeLoop phase input_fn
704 705 706 707
                       return ()
               _ ->
                   return ()
           return r
708

709 710 711 712 713
runHookedPhase :: PhasePlus -> FilePath -> DynFlags
               -> CompPipeline (PhasePlus, FilePath)
runHookedPhase pp input dflags =
  lookupHook runPhaseHook runPhase dflags pp input dflags

714 715 716 717
-- -----------------------------------------------------------------------------
-- In each phase, we need to know into what filename to generate the
-- output.  All the logic about which filenames we generate output
-- into is embodied in the following function.
718

719 720 721
-- | Computes the next output filename after we run @next_phase@.
-- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad
-- (which specifies all of the ambient information.)
722 723 724 725 726 727 728 729
phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
phaseOutputFilename next_phase = do
  PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
  PipeState{maybe_loc, hsc_env} <- getPipeState
  let dflags = hsc_dflags hsc_env
  liftIO $ getOutputFilename stop_phase output_spec
                             src_basename dflags next_phase maybe_loc

730 731 732 733 734 735 736 737 738 739 740 741 742 743 744
-- | Computes the next output filename for something in the compilation
-- pipeline.  This is controlled by several variables:
--
--      1. 'Phase': the last phase to be run (e.g. 'stopPhase').  This
--         is used to tell if we're in the last phase or not, because
--         in that case flags like @-o@ may be important.
--      2. 'PipelineOutput': is this intended to be a 'Temporary' or
--         'Persistent' build output?  Temporary files just go in
--         a fresh temporary name.
--      3. 'String': what was the basename of the original input file?
--      4. 'DynFlags': the obvious thing
--      5. 'Phase': the phase we want to determine the output filename of.
--      6. @Maybe ModLocation@: the 'ModLocation' of the module we're
--         compiling; this can be used to override the default output
--         of an object file.  (TODO: do we actually need this?)
745
getOutputFilename
746 747
  :: Phase -> PipelineOutput -> String
  -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
748
getOutputFilename stop_phase output basename dflags next_phase maybe_location
749 750 751 752 753 754
 | is_last_phase, Persistent   <- output = persistent_fn
 | is_last_phase, SpecificFile <- output = case outputFile dflags of
                                           Just f -> return f
                                           Nothing ->
                                               panic "SpecificFile: No filename"
 | keep_this_output                      = persistent_fn
Douglas Wilson's avatar
Douglas Wilson committed
755 756 757
 | Temporary lifetime <- output          = newTempName dflags lifetime suffix
 | otherwise                             = newTempName dflags TFL_CurrentModule
   suffix
758 759 760 761 762
    where
          hcsuf      = hcSuf dflags
          odir       = objectDir dflags
          osuf       = objectSuf dflags
          keep_hc    = gopt Opt_KeepHcFiles dflags
Roland Senn's avatar
Roland Senn committed
763
          keep_hscpp = gopt Opt_KeepHscppFiles dflags
764 765 766 767
          keep_s     = gopt Opt_KeepSFiles dflags
          keep_bc    = gopt Opt_KeepLlvmFiles dflags

          myPhaseInputExt HCc       = hcsuf
768
          myPhaseInputExt MergeForeign = osuf
769 770 771 772 773 774 775 776
          myPhaseInputExt StopLn    = osuf
          myPhaseInputExt other     = phaseInputExt other

          is_last_phase = next_phase `eqPhase` stop_phase

          -- sometimes, we keep output from intermediate stages
          keep_this_output =
               case next_phase of
Simon Marlow's avatar
Simon Marlow committed
777
                       As _    | keep_s     -> True
778 779
                       LlvmOpt | keep_bc    -> True
                       HCc     | keep_hc    -> True
780
                       HsPp _  | keep_hscpp -> True   -- See #10869
781 782 783 784 785 786 787 788 789 790 791 792 793 794 795
                       _other               -> False

          suffix = myPhaseInputExt next_phase

          -- persistent object files get put in odir
          persistent_fn
             | StopLn <- next_phase = return odir_persistent
             | otherwise            = return persistent

          persistent = basename <.> suffix

          odir_persistent
             | Just loc <- maybe_location = ml_obj_file loc
             | Just d <- odir = d </> persistent
             | otherwise      = persistent
796

Moritz Angermann's avatar
Moritz Angermann committed
797 798

-- | The fast LLVM Pipeline skips the mangler and assembler,
Gabor Greif's avatar
Gabor Greif committed
799
-- emitting object code directly from llc.
Moritz Angermann's avatar
Moritz Angermann committed
800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824
--
-- slow: opt -> llc -> .s -> mangler -> as -> .o
-- fast: opt -> llc -> .o
--
-- hidden flag: -ffast-llvm
--
-- if keep-s-files is specified, we need to go through
-- the slow pipeline (Kavon Farvardin requested this).
fastLlvmPipeline :: DynFlags -> Bool
fastLlvmPipeline dflags
  = not (gopt Opt_KeepSFiles dflags) && gopt Opt_FastLlvm dflags

-- | LLVM Options. These are flags to be passed to opt and llc, to ensure
-- consistency we list them in pairs, so that they form groups.
llvmOptions :: DynFlags
            -> [(String, String)]  -- ^ pairs of (opt, llc) arguments
llvmOptions dflags =
       [("-enable-tbaa -tbaa",  "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]
    ++ [("-relocation-model=" ++ rmodel
        ,"-relocation-model=" ++ rmodel) | not (null rmodel)]
    ++ [("-stack-alignment=" ++ (show align)
        ,"-stack-alignment=" ++ (show align)) | align > 0 ]
    ++ [("", "-filetype=obj") | fastLlvmPipeline dflags ]

    -- Additional llc flags
825 826
    ++ [("", "-mcpu=" ++ mcpu)   | not (null mcpu)
                                 , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]
Moritz Angermann's avatar
Moritz Angermann committed
827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852