DriverPipeline.hs 97 KB
Newer Older
1 2
{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation #-}
{-# 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, mergeRequirement,
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 28
        -- Misc utility
   makeMergeRequirementSummary,

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

#include "HsVersions.h"

41
import PipelineMonad
42
import Packages
43
import HeaderInfo
44
import DriverPhases
45
import SysTools
46
import HscMain
47
import Finder
48
import HscTypes hiding ( Hsc )
49 50
import Outputable
import Module
Ian Lynagh's avatar
Ian Lynagh committed
51
import UniqFM           ( eltsUFM )
52
import ErrUtils
53
import DynFlags
54
import Config
55
import Panic
56
import Util
Ian Lynagh's avatar
Ian Lynagh committed
57 58 59
import StringBuffer     ( hGetStringBuffer )
import BasicTypes       ( SuccessFlag(..) )
import Maybes           ( expectJust )
60
import SrcLoc
61
import FastString
62
import LlvmCodeGen      ( llvmFixupAsm )
63
import MonadUtils
64
import Platform
65
import TcRnTypes
66
import Hooks
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
thoughtpolice's avatar
thoughtpolice committed
73
import Data.List        ( isSuffixOf )
Simon Marlow's avatar
Simon Marlow committed
74
import Data.Maybe
75
import Data.Char
76
import Data.Time
77

78 79
-- ---------------------------------------------------------------------------
-- Pre-process
80

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

87
preprocess :: HscEnv
88
           -> (FilePath, Maybe Phase) -- ^ filename and starting phase
89
           -> IO (DynFlags, FilePath)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
90
preprocess hsc_env (filename, mb_phase) =
Ian Lynagh's avatar
Ian Lynagh committed
91
  ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
92
  runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase)
93
        Nothing Temporary Nothing{-no ModLocation-} Nothing{-no stub-}
94

95
-- ---------------------------------------------------------------------------
96

97 98
-- | Compile
--
99 100 101 102
-- 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
103 104 105
-- 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.
106
--
107 108
-- NB.  No old interface can also mean that the source has changed.

109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
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
134
 = do
135

136
   debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)
137

138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 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 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216
   (status, hmi0) <- hscIncrementalCompile
                        always_do_basic_recompilation_check
                        m_tc_result mHscMessage
                        hsc_env summary source_modified mb_old_iface (mod_index, nmods)

   case (status, hsc_lang) of
        (HscUpToDate, _) ->
            ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )
            return hmi0 { hm_linkable = maybe_old_linkable }
        (HscNotGeneratingCode, HscNothing) ->
            let mb_linkable = if isHsBoot src_flavour
                                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
        (HscUpdateBootMerge, HscInterpreted) ->
            let linkable = LM (ms_hs_date summary) this_mod []
            in return hmi0 { hm_linkable = Just linkable }
        (HscUpdateBootMerge, _) -> do
            output_fn <- getOutputFilename next_phase
                            Temporary basename dflags next_phase (Just location)

            -- #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
                                            mod_name HscUpdateBootMerge))
                              (Just basename)
                              Persistent
                              (Just location)
                              Nothing
            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
            (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary

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

            let hs_unlinked = [BCOs comp_bc modBreaks]
                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
                            Temporary basename dflags next_phase (Just location)
            -- 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)
                              Nothing
                  -- 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 }

217 218 219 220 221 222 223 224 225 226 227
 where dflags0     = ms_hspp_opts summary
       location    = ms_location summary
       input_fn    = expectJust "compile:hs" (ml_hs_file location)
       input_fnpp  = ms_hspp_file summary
       mod_graph   = hsc_mod_graph hsc_env0
       needsTH     = any (xopt Opt_TemplateHaskell . ms_hspp_opts) mod_graph
       needsQQ     = any (xopt Opt_QuasiQuotes     . ms_hspp_opts) mod_graph
       needsLinker = needsTH || needsQQ
       isDynWay    = any (== WayDyn) (ways dflags0)
       isProfWay   = any (== WayProf) (ways dflags0)

228 229 230 231 232 233 234

       src_flavour = ms_hsc_src summary
       this_mod = ms_mod summary
       mod_name = ms_mod_name summary
       next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
       object_filename = ml_obj_file location

235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263
       -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
       -- the linker can correctly load the object files.

       dflags1 = if needsLinker && dynamicGhc && not isDynWay && not isProfWay
                  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
       dflags      = dflags1 { includePaths = current_dir : old_paths }
       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
264

265
-----------------------------------------------------------------------------
266 267
-- stub .h and .c files (for foreign export support)

268 269 270
-- The _stub.c file is derived from the haskell source file, possibly taking
-- into account the -stubdir option.
--
271 272 273
-- 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
-- (see the MergeStubs phase).
274

275 276 277 278
compileStub :: HscEnv -> FilePath -> IO FilePath
compileStub hsc_env stub_c = do
        (_, stub_o) <- runPipeline StopLn hsc_env (stub_c,Nothing)  Nothing
                                   Temporary Nothing{-no ModLocation-} Nothing
279

Ian Lynagh's avatar
Ian Lynagh committed
280
        return stub_o
281

282 283 284 285 286 287 288 289 290 291 292 293 294 295 296
compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> IO ()
compileEmptyStub dflags hsc_env basename location = do
  -- To maintain the invariant that every Haskell file
  -- compiles to object code, we make an empty (but
  -- valid) stub object file for signatures
  empty_stub <- newTempName dflags "c"
  writeFile empty_stub ""
  _ <- runPipeline StopLn hsc_env
                  (empty_stub, Nothing)
                  (Just basename)
                  Persistent
                  (Just location)
                  Nothing
  return ()

297 298
-- ---------------------------------------------------------------------------
-- Link
299

Ian Lynagh's avatar
Ian Lynagh committed
300 301 302 303
link :: GhcLink                 -- interactive or batch
     -> DynFlags                -- dynamic flags
     -> Bool                    -- attempt linking in batch mode?
     -> HomePackageTable        -- what to link
304 305 306 307 308 309 310 311 312
     -> 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.

313 314 315 316 317 318 319 320
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
321

322 323
    l NoLink _ _ _
      = return Succeeded
324

325 326
    l LinkBinary dflags batch_attempt_linking hpt
      = link' dflags batch_attempt_linking hpt
327

328 329
    l LinkStaticLib dflags batch_attempt_linking hpt
      = link' dflags batch_attempt_linking hpt
330

331 332
    l LinkDynLib dflags batch_attempt_linking hpt
      = link' dflags batch_attempt_linking hpt
333 334 335 336 337 338 339 340 341 342 343

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
344
   | batch_attempt_linking
Ian Lynagh's avatar
Ian Lynagh committed
345 346
   = do
        let
347 348 349 350
            staticLink = case ghcLink dflags of
                          LinkStaticLib -> True
                          _ -> platformBinariesAreStaticLibs (targetPlatform dflags)

351
            home_mod_infos = eltsUFM hpt
352

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

Ian Lynagh's avatar
Ian Lynagh committed
356 357
            -- the linkables to link
            linkables = map (expectJust "link".hm_linkable) home_mod_infos
358

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

Ian Lynagh's avatar
Ian Lynagh committed
361 362 363 364 365
        -- 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
366

Ian Lynagh's avatar
Ian Lynagh committed
367 368
        let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
            obj_files = concatMap getOfiles linkables
369

370
            exe_file = exeFileName staticLink dflags
371

372
        linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps
373

ian@well-typed.com's avatar
ian@well-typed.com committed
374
        if not (gopt Opt_ForceRecomp dflags) && not linking_needed
375
           then do debugTraceMsg dflags 2 (text exe_file <+> ptext (sLit "is up to date, linking not required."))
Ian Lynagh's avatar
Ian Lynagh committed
376 377
                   return Succeeded
           else do
378

Ian Lynagh's avatar
Ian Lynagh committed
379
        compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...")
380

Ian Lynagh's avatar
Ian Lynagh committed
381 382
        -- Don't showPass in Batch mode; doLink will do that for us.
        let link = case ghcLink dflags of
383 384 385 386
                LinkBinary    -> linkBinary
                LinkStaticLib -> linkStaticLibCheck
                LinkDynLib    -> linkDynLibCheck
                other         -> panicBadLink other
Ian Lynagh's avatar
Ian Lynagh committed
387
        link dflags obj_files pkg_deps
388

389
        debugTraceMsg dflags 3 (text "link: done")
390

Ian Lynagh's avatar
Ian Lynagh committed
391
        -- linkBinary only returns if it succeeds
392 393 394
        return Succeeded

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

399

400
linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [PackageKey] -> IO Bool
401
linkingNeeded dflags staticLink linkables pkg_deps = do
402 403 404
        -- 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).
405
  let exe_file = exeFileName staticLink dflags
406
  e_exe_time <- tryIO $ getModificationUTCTime exe_file
407 408 409 410
  case e_exe_time of
    Left _  -> return True
    Right t -> do
        -- first check object files and extra_ld_inputs
411
        let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
412
        e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs
413 414 415
        let (errs,extra_times) = splitEithers e_extra_times
        let obj_times =  map linkableTime linkables ++ extra_times
        if not (null errs) || any (t <) obj_times
Ian Lynagh's avatar
Ian Lynagh committed
416
            then return True
417 418 419 420
            else do

        -- next, check libraries. XXX this only checks Haskell libraries,
        -- not extra_libraries or -l things from the command line.
421 422
        let pkg_hslibs  = [ (libraryDirs c, lib)
                          | Just c <- map (lookupPackage dflags) pkg_deps,
423 424
                            lib <- packageHsLibs dflags c ]

425
        pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs
426
        if any isNothing pkg_libfiles then return True else do
427
        e_lib_times <- mapM (tryIO . getModificationUTCTime)
428 429 430 431
                          (catMaybes pkg_libfiles)
        let (lib_errs,lib_times) = splitEithers e_lib_times
        if not (null lib_errs) || any (t <) lib_times
           then return True
432 433 434 435
           else checkLinkInfo dflags pkg_deps exe_file

-- Returns 'False' if it was, and we can avoid linking, because the
-- previous binary was linked with "the same options".
436
checkLinkInfo :: DynFlags -> [PackageKey] -> FilePath -> IO Bool
437
checkLinkInfo dflags pkg_deps exe_file
438
 | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
439 440 441 442 443 444 445 446 447 448 449 450 451 452
 -- ToDo: Windows and OS X do not use the ELF binary format, so
 -- readelf does not work there.  We need to find another way to do
 -- this.
 = return False -- conservatively we should return True, but not
                -- linking in this case was the behaviour for a long
                -- time so we leave it as-is.
 | otherwise
 = do
   link_info <- getLinkInfo dflags pkg_deps
   debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info)
   m_exe_link_info <- readElfSection dflags ghcLinkInfoSectionName exe_file
   debugTraceMsg dflags 3 $ text ("Exe link info: " ++ show m_exe_link_info)
   return (Just link_info /= m_exe_link_info)

453 454 455 456 457
platformSupportsSavingLinkOpts :: OS -> Bool
platformSupportsSavingLinkOpts os
  | os == OSSolaris2 = False -- see #5382
  | otherwise        = osElfTarget os

458 459 460
ghcLinkInfoSectionName :: String
ghcLinkInfoSectionName = ".debug-ghc-link-info"
   -- if we use the ".debug" prefix, then strip will strip it by default
461

462 463
findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath)
findHSLib dflags dirs lib = do
ian@well-typed.com's avatar
ian@well-typed.com committed
464
  let batch_lib_file = if gopt Opt_Static dflags
465 466
                       then "lib" ++ lib <.> "a"
                       else mkSOName (targetPlatform dflags) lib
467 468 469 470 471
  found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
  case found of
    [] -> return Nothing
    (x:_) -> return (Just x)

472 473 474
-- -----------------------------------------------------------------------------
-- Compile files in one-shot mode.

475
oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
476 477
oneShot hsc_env stop_phase srcs = do
  o_files <- mapM (compileFile hsc_env stop_phase) srcs
478
  doLink (hsc_dflags hsc_env) stop_phase o_files
479

480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523
-- | Constructs a 'ModSummary' for a "signature merge" node.
-- This is a simplified construction function which only checks
-- for a local hs-boot file.
makeMergeRequirementSummary :: HscEnv -> Bool -> ModuleName -> IO ModSummary
makeMergeRequirementSummary hsc_env obj_allowed mod_name = do
    let dflags = hsc_dflags hsc_env
    location <- liftIO $ mkHomeModLocation2 dflags mod_name
                         (moduleNameSlashes mod_name) (hiSuf dflags)
    obj_timestamp <-
         if isObjectTarget (hscTarget dflags) || obj_allowed -- bug #1205
             then liftIO $ modificationTimeIfExists (ml_obj_file location)
             else return Nothing
    r <- findHomeModule hsc_env mod_name
    let has_local_boot = case r of
                            Found _ _ -> True
                            _ -> False
    src_timestamp <- case obj_timestamp of
                        Just date -> return date
                        Nothing -> getCurrentTime -- something fake
    return ModSummary {
            ms_mod = mkModule (thisPackage dflags) mod_name,
            ms_hsc_src = HsBootMerge,
            ms_location = location,
            ms_hs_date = src_timestamp,
            ms_obj_date = obj_timestamp,
            ms_iface_date = Nothing,
            -- TODO: fill this in with all the imports eventually
            ms_srcimps = [],
            ms_textual_imps = [],
            ms_merge_imps = (has_local_boot, []),
            ms_hspp_file = "FAKE",
            ms_hspp_opts = dflags,
            ms_hspp_buf = Nothing
            }

-- | Top-level entry point for @ghc -merge-requirement ModName@.
mergeRequirement :: HscEnv -> ModuleName -> IO ()
mergeRequirement hsc_env mod_name = do
    mod_summary <- makeMergeRequirementSummary hsc_env True mod_name
    -- Based off of GhcMake handling
    _ <- liftIO $ compileOne' Nothing Nothing hsc_env mod_summary 1 1 Nothing
                              Nothing SourceUnmodified
    return ()

524
compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
525
compileFile hsc_env stop_phase (src, mb_phase) = do
526
   exists <- doesFileExist src
Ian Lynagh's avatar
Ian Lynagh committed
527
   when (not exists) $
528
        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))
Ian Lynagh's avatar
Ian Lynagh committed
529

530
   let
Austin Seipp's avatar
Austin Seipp committed
531
        dflags    = hsc_dflags hsc_env
ian@well-typed.com's avatar
ian@well-typed.com committed
532
        split     = gopt Opt_SplitObjs dflags
Ian Lynagh's avatar
Ian Lynagh committed
533 534
        mb_o_file = outputFile dflags
        ghc_link  = ghcLink dflags      -- Set by -c or -no-link
535

Ian Lynagh's avatar
Ian Lynagh committed
536 537
        -- When linking, the -o argument refers to the linker's output.
        -- otherwise, we use it as the name for the pipeline's output.
538
        output
539 540 541 542
         -- If we are dong -fno-code, then act as if the output is
         -- 'Temporary'. This stops GHC trying to copy files to their
         -- final location.
         | HscNothing <- hscTarget dflags = Temporary
Ian Lynagh's avatar
Ian Lynagh committed
543 544
         | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
                -- -o foo applies to linker
545
         | isJust mb_o_file = SpecificFile
Ian Lynagh's avatar
Ian Lynagh committed
546 547 548 549
                -- -o foo applies to the file we are compiling now
         | otherwise = Persistent

        stop_phase' = case stop_phase of
Simon Marlow's avatar
Simon Marlow committed
550 551
                        As _ | split -> SplitAs
                        _            -> stop_phase
552

553
   ( _, out_file) <- runPipeline stop_phase' hsc_env
554
                            (src, fmap RealPhase mb_phase) Nothing output
555
                            Nothing{-no ModLocation-} Nothing
556 557 558 559 560 561
   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
562
  = return ()           -- We stopped before the linking phase
563 564 565

  | otherwise
  = case ghcLink dflags of
566 567 568 569 570
        NoLink        -> return ()
        LinkBinary    -> linkBinary         dflags o_files []
        LinkStaticLib -> linkStaticLibCheck dflags o_files []
        LinkDynLib    -> linkDynLibCheck    dflags o_files []
        other         -> panicBadLink other
571 572


573
-- ---------------------------------------------------------------------------
574

575 576 577 578 579 580 581
-- | 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
582
-- OPTIONS_GHC pragmas), and the changes affect later phases in the
583
-- pipeline.
584
runPipeline
585
  :: Phase                      -- ^ When to stop
586
  -> HscEnv                     -- ^ Compilation environment
587
  -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix)
588
  -> Maybe FilePath             -- ^ original basename (if different from ^^^)
Ian Lynagh's avatar
Ian Lynagh committed
589
  -> PipelineOutput             -- ^ Output filename
590
  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
591
  -> Maybe FilePath             -- ^ stub object, if we have one
592
  -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)
593
runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
594
             mb_basename output maybe_loc maybe_stub_o
595 596 597 598 599 600 601 602 603 604 605 606 607

    = 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
608
             -- If we were given a -x flag, then use that phase to start from
609
             start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase
ian@well-typed.com's avatar
ian@well-typed.com committed
610

611 612 613 614 615 616
             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
617 618 619

             isHaskellishFile = isHaskell start_phase

620
             env = PipeEnv{ stop_phase,
621
                            src_filename = input_fn,
622 623 624 625 626 627 628
                            src_basename = basename,
                            src_suffix = suffix',
                            output_spec = output }

         -- 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.
629
         let happensBefore' = happensBefore dflags
630 631
         case start_phase of
             RealPhase start_phase' ->
632 633 634 635
                 -- 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)) $
636 637 638 639
                       throwGhcExceptionIO (UsageError
                                   ("cannot compile this file to desired target: "
                                      ++ input_fn))
             HscOut {} -> return ()
640

ian@well-typed.com's avatar
ian@well-typed.com committed
641
         debugTraceMsg dflags 4 (text "Running the pipeline")
642
         r <- runPipeline' start_phase hsc_env env input_fn
643
                           maybe_loc maybe_stub_o
ian@well-typed.com's avatar
ian@well-typed.com committed
644 645 646 647

         -- 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
648
         let dflags = extractDynFlags hsc_env
Austin Seipp's avatar
Austin Seipp committed
649 650 651 652 653 654 655 656 657 658
         -- 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
                                 maybe_loc maybe_stub_o
               return ()
659 660 661
         return r

runPipeline'
662
  :: PhasePlus                  -- ^ When to start
663
  -> HscEnv                     -- ^ Compilation environment
664 665
  -> PipeEnv
  -> FilePath                   -- ^ Input filename
666 667
  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
  -> Maybe FilePath             -- ^ stub object, if we have one
668
  -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)
669
runPipeline' start_phase hsc_env env input_fn
670
             maybe_loc maybe_stub_o
671
  = do
672
  -- Execute the pipeline...
673
  let state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o }
674

675
  evalP (pipeLoop start_phase input_fn) env state
676

677 678 679 680
-- ---------------------------------------------------------------------------
-- outer pipeline loop

-- | pipeLoop runs phases until we reach the stop phase
681
pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
682
pipeLoop phase input_fn = do
683
  env <- getPipeEnv
684
  dflags <- getDynFlags
685
  -- See Note [Partial ordering on phases]
686
  let happensBefore' = happensBefore dflags
687
      stopPhase = stop_phase env
688 689
  case phase of
   RealPhase realPhase | realPhase `eqPhase` stopPhase            -- All done
690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709
     -> -- 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
        Temporary ->
            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)


710
     | not (realPhase `happensBefore'` stopPhase)
Ian Lynagh's avatar
Ian Lynagh committed
711 712 713 714
        -- 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 #-}.
715
     -> panic ("pipeLoop: at phase " ++ show realPhase ++
716
           " but I wanted to stop at phase " ++ show stopPhase)
Ian Lynagh's avatar
Ian Lynagh committed
717

718
   _
719
     -> do liftIO $ debugTraceMsg dflags 4
720
                                  (ptext (sLit "Running phase") <+> ppr phase)
721
           (next_phase, output_fn) <- runHookedPhase phase input_fn dflags
722
           r <- pipeLoop next_phase output_fn
723
           case phase of
724 725
               HscOut {} ->
                   whenGeneratingDynamicToo dflags $ do
726
                       setDynFlags $ dynamicTooMkDynamicDynFlags dflags
727
                       -- TODO shouldn't ignore result:
728
                       _ <- pipeLoop phase input_fn
729 730 731 732
                       return ()
               _ ->
                   return ()
           return r
733

734 735 736 737 738
runHookedPhase :: PhasePlus -> FilePath -> DynFlags
               -> CompPipeline (PhasePlus, FilePath)
runHookedPhase pp input dflags =
  lookupHook runPhaseHook runPhase dflags pp input dflags

739 740 741 742
-- -----------------------------------------------------------------------------
-- 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.
743

744 745 746 747 748 749 750 751
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

752
getOutputFilename
753 754
  :: Phase -> PipelineOutput -> String
  -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
755
getOutputFilename stop_phase output basename dflags next_phase maybe_location
756 757 758 759 760 761 762
 | 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
 | otherwise                             = newTempName dflags suffix
763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780
    where
          hcsuf      = hcSuf dflags
          odir       = objectDir dflags
          osuf       = objectSuf dflags
          keep_hc    = gopt Opt_KeepHcFiles dflags
          keep_s     = gopt Opt_KeepSFiles dflags
          keep_bc    = gopt Opt_KeepLlvmFiles dflags

          myPhaseInputExt HCc       = hcsuf
          myPhaseInputExt MergeStub = osuf
          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
781
                       As _    | keep_s     -> True
782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798
                       LlvmOpt | keep_bc    -> True
                       HCc     | keep_hc    -> True
                       _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
799

800
-- -----------------------------------------------------------------------------
801
-- | Each phase in the pipeline returns the next phase to execute, and the
802 803 804 805 806 807
-- name of the file in which the output was placed.
--
-- We must do things dynamically this way, because we often don't know
-- what the rest of the phases will be until part-way through the
-- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
-- of a source file can change the latter stages of the pipeline from
808
-- taking the LLVM route to using the native code generator.
809
--
810
runPhase :: PhasePlus   -- ^ Run this phase
811 812
         -> FilePath    -- ^ name of the input file
         -> DynFlags    -- ^ for convenience, we pass the current dflags in
813
         -> CompPipeline (PhasePlus,           -- next phase to run
814
                          FilePath)            -- output filename
Ian Lynagh's avatar
Ian Lynagh committed
815 816 817 818

        -- Invariant: the output filename always contains the output
        -- Interesting case: Hsc when there is no recompilation to do
        --                   Then the output filename is still a .o file
819

820

821
-------------------------------------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
822
-- Unlit phase
823

824
runPhase (RealPhase (Unlit sf)) input_fn dflags
825
  = do
826
       output_fn <- phaseOutputFilename (Cpp sf)
827

828
       let flags = [ -- The -h option passes the file name for unlit to
829 830
                     -- put in a #line directive
                     SysTools.Option     "-h"
831 832
                     -- See Note [Don't normalise input filenames].
                   , SysTools.Option $ escape input_fn
833 834 835 836
                   , SysTools.FileOption "" input_fn
                   , SysTools.FileOption "" output_fn
                   ]

837
       liftIO $ SysTools.runUnlit dflags flags
838

839
       return (RealPhase (Cpp sf), output_fn)
840 841 842 843
  where
       -- escape the characters \, ", and ', but don't try to escape
       -- Unicode or anything else (so we don't use Util.charToC
       -- here).  If we get this wrong, then in
844
       -- Coverage.isGoodTickSrcSpan where we check that the filename in
845 846
       -- a SrcLoc is the same as the source filenaame, the two will
       -- look bogusly different. See test:
847
       -- libraries/hpc/tests/function/subdir/tough2.hs
848 849 850 851 852
       escape ('\\':cs) = '\\':'\\': escape cs
       escape ('\"':cs) = '\\':'\"': escape cs
       escape ('\'':cs) = '\\':'\'': escape cs
       escape (c:cs)    = c : escape cs
       escape []        = []
853 854

-------------------------------------------------------------------------------
855
-- Cpp phase : (a) gets OPTIONS out of file
Ian Lynagh's avatar
Ian Lynagh committed
856
--             (b) runs cpp if necessary
857

858
runPhase (RealPhase (Cpp sf)) input_fn dflags0
859
  = do
860
       src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
861
       (dflags1, unhandled_flags, warns)
862
           <- liftIO $ parseDynamicFilePragma dflags0 src_opts
863
       setDynFlags dflags1
864
       liftIO $ checkProcessArgsResult dflags1 unhandled_flags
865

866
       if not (xopt Opt_Cpp dflags1) then do
867
           -- we have to be careful to emit warnings only once.
868 869
           unless (gopt Opt_Pp dflags1) $
               liftIO $ handleFlagWarnings dflags1 warns
870

sof's avatar
sof committed
871
           -- no need to preprocess CPP, just pass input file along
Ian Lynagh's avatar
Ian Lynagh committed
872
           -- to the next phase of the pipeline.
873
           return (RealPhase (HsPp sf), input_fn)
Ian Lynagh's avatar
Ian Lynagh committed
874
        else do
875
            output_fn <- phaseOutputFilename (HsPp sf)
876
            liftIO $ doCpp dflags1 True{-raw-}
877
                           input_fn output_fn
878 879
            -- re-read the pragmas now that we've preprocessed the file
            -- See #2464,#3457
880
            src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
881
            (dflags2, unhandled_flags, warns)
882 883 884 885
                <- liftIO $ parseDynamicFilePragma dflags0 src_opts
            liftIO $ checkProcessArgsResult dflags2 unhandled_flags
            unless (gopt Opt_Pp dflags2) $
                liftIO $ handleFlagWarnings dflags2 warns
886
            -- the HsPp pass below will emit warnings
887 888

            setDynFlags dflags2
889

890
            return (RealPhase (HsPp sf), output_fn)
891

sof's avatar
sof committed
892
-------------------------------------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
893
-- HsPp phase
sof's avatar
sof committed
894

895
runPhase (RealPhase (HsPp sf)) input_fn dflags
896
  = do
ian@well-typed.com's avatar
ian@well-typed.com committed
897
       if not (gopt Opt_Pp dflags) then
sof's avatar
sof committed
898
           -- no need to preprocess, just pass input file along
Ian Lynagh's avatar
Ian Lynagh committed
899
           -- to the next phase of the pipeline.
900
          return (RealPhase (Hsc sf), input_fn)
Ian Lynagh's avatar
Ian Lynagh committed
901
        else do
902 903 904
            PipeEnv{src_basename, src_suffix} <- getPipeEnv
            let orig_fn = src_basename <.> src_suffix
            output_fn <- phaseOutputFilename (Hsc sf)
905
            liftIO $ SysTools.runPp dflags
Ian Lynagh's avatar
Ian Lynagh committed
906 907 908
                           ( [ SysTools.Option     orig_fn
                             , SysTools.Option     input_fn
                             , SysTools.FileOption "" output_fn
909
                             ]
Ian Lynagh's avatar
Ian Lynagh committed
910
                           )
911 912

            -- re-read pragmas now that we've parsed the file (see #3674)
913
            src_opts <- liftIO $ getOptionsFromFile dflags output_fn
914
            (dflags1, unhandled_flags, warns)
915
                <- liftIO $ parseDynamicFilePragma dflags src_opts
916
            setDynFlags dflags1
917 918
            liftIO $ checkProcessArgsResult dflags1 unhandled_flags
            liftIO $ handleFlagWarnings dflags1 warns
919

920
            return (RealPhase (Hsc sf), output_fn)
921

922 923 924
-----------------------------------------------------------------------------
-- Hsc phase

925 926
-- Compilation of a single module, in "legacy" mode (_not_ under
-- the direction of the compilation manager).
927
runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
Ian Lynagh's avatar
Ian Lynagh committed
928
 = do   -- normal Hsc mode, not mkdependHS
929 930 931 932

        PipeEnv{ stop_phase=stop,
                 src_basename=basename,
                 src_suffix=suff } <- getPipeEnv
933

934
  -- we add the current directory (i.e. the directory in which
935
  -- the .hs files resides) to the include path, since this is
936
  -- what gcc does, and it's probably what you want.
937
        let current_dir = takeDirectory basename
Ian Lynagh's avatar
Ian Lynagh committed
938 939 940
            paths = includePaths dflags0
            dflags = dflags0 { includePaths = current_dir : paths }

941 942
        setDynFlags dflags

943
  -- gather the imports and module name
Austin Seipp's avatar
Austin Seipp committed
944 945 946 947 948
        (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do
          do
            buf <- hGetStringBuffer input_fn
            (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
            return (Just buf, mod_name, imps, src_imps)
949 950 951 952 953 954

  -- Take -o into account if present
  -- Very like -ohi, but we must *only* do this if we aren't linking
  -- (If we're linking then the -o applies to the linked thing, not to
  -- the object file for one module.)
  -- Note the nasty duplication with the same computation in compileFile above
955
        location <- getLocation src_flavour mod_name
956

957
        let o_file = ml_obj_file location -- The real object file
958 959 960 961 962
            hi_file = ml_hi_file location
            dest_file | writeInterfaceOnlyMode dflags
                            = hi_file
                      | otherwise
                            = o_file
963 964

  -- Figure out if the source has changed, for recompilation avoidance.