DriverPipeline.hs 99.5 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,
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
Moritz Angermann's avatar
Moritz Angermann committed
73
import Data.List        ( isSuffixOf, intercalate )
Simon Marlow's avatar
Simon Marlow committed
74
import Data.Maybe
75
import Data.Version
76
import Data.Either      ( partitionEithers )
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)
Douglas Wilson's avatar
Douglas Wilson committed
93
94
95
96
97
98
        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-}
99

100
-- ---------------------------------------------------------------------------
101

102
103
-- | Compile
--
104
105
106
107
-- 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
108
109
110
-- 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.
111
--
112
113
-- NB.  No old interface can also mean that the source has changed.

114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
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
139
 = do
140

141
   debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)
142

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

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

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

            -- #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
188
                                            mod_name HscUpdateSig))
189
190
191
                              (Just basename)
                              Persistent
                              (Just location)
192
                              []
193
194
195
196
            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
197
198
            (hasStub, comp_bc, spt_entries) <-
                hscInteractive hsc_env cgguts summary
199
200
201
202
203
204
205

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

206
            let hs_unlinked = [BCOs comp_bc spt_entries]
207
208
209
210
211
212
213
214
215
216
217
218
                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
219
220
                            (Temporary TFL_CurrentModule)
                            basename dflags next_phase (Just location)
221
222
223
224
225
226
227
            -- 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)
228
                              []
229
230
231
232
233
                  -- 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 }

234
 where dflags0     = ms_hspp_opts summary
Edward Z. Yang's avatar
Edward Z. Yang committed
235
236

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

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

251
       -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
252
253
       -- the linker can correctly load the object files.  This isn't necessary
       -- when using -fexternal-interpreter.
Douglas Wilson's avatar
Douglas Wilson committed
254
255
       dflags1 = if dynamicGhc && internalInterpreter &&
                    not isDynWay && not isProfWay && needsLinker
256
257
258
259
260
261
262
263
264
265
                  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
266
267
       prevailing_dflags = hsc_dflags hsc_env0
       dflags =
268
          dflags1 { includePaths = addQuoteInclude old_paths [current_dir]
269
270
271
272
273
274
                  , log_action = log_action prevailing_dflags
                  , log_finaliser = log_finaliser prevailing_dflags }
                  -- 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.
275
276
277
278
279
280
281
282
283
284
285
286
287
288
       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
289

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

293
294
295
-- The _stub.c file is derived from the haskell source file, possibly taking
-- into account the -stubdir option.
--
296
297
-- 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
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
-- (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
compileForeign hsc_env lang stub_c = do
        let phase = case lang of
              LangC -> Cc
              LangCxx -> Ccxx
              LangObjc -> Cobjc
              LangObjcxx -> Cobjcxx
        (_, stub_o) <- runPipeline StopLn hsc_env
                       (stub_c, Just (RealPhase phase))
Douglas Wilson's avatar
Douglas Wilson committed
313
314
315
                       Nothing (Temporary TFL_GhcSession)
                       Nothing{-no ModLocation-}
                       []
Ian Lynagh's avatar
Ian Lynagh committed
316
        return stub_o
317

318
319
320
compileStub :: HscEnv -> FilePath -> IO FilePath
compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c

321
322
compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
compileEmptyStub dflags hsc_env basename location mod_name = do
323
324
  -- To maintain the invariant that every Haskell file
  -- compiles to object code, we make an empty (but
325
326
327
328
329
  -- 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
  -- http://ghc.haskell.org/trac/ghc/ticket/12673
  -- and https://github.com/haskell/cabal/issues/2257
Douglas Wilson's avatar
Douglas Wilson committed
330
  empty_stub <- newTempName dflags TFL_CurrentModule "c"
331
332
  let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;"
  writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
333
334
335
336
337
  _ <- runPipeline StopLn hsc_env
                  (empty_stub, Nothing)
                  (Just basename)
                  Persistent
                  (Just location)
338
                  []
339
340
  return ()

341
342
-- ---------------------------------------------------------------------------
-- Link
343

Ian Lynagh's avatar
Ian Lynagh committed
344
345
346
347
link :: GhcLink                 -- interactive or batch
     -> DynFlags                -- dynamic flags
     -> Bool                    -- attempt linking in batch mode?
     -> HomePackageTable        -- what to link
348
349
350
351
352
353
354
355
356
     -> 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.

357
358
359
360
361
362
363
364
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
365

366
367
    l NoLink _ _ _
      = return Succeeded
368

369
370
    l LinkBinary dflags batch_attempt_linking hpt
      = link' dflags batch_attempt_linking hpt
371

372
373
    l LinkStaticLib dflags batch_attempt_linking hpt
      = link' dflags batch_attempt_linking hpt
374

375
376
    l LinkDynLib dflags batch_attempt_linking hpt
      = link' dflags batch_attempt_linking hpt
377
378
379
380
381
382
383
384
385
386
387

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
388
   | batch_attempt_linking
Ian Lynagh's avatar
Ian Lynagh committed
389
390
   = do
        let
391
392
            staticLink = case ghcLink dflags of
                          LinkStaticLib -> True
393
                          _ -> False
394

niteria's avatar
niteria committed
395
            home_mod_infos = eltsHpt hpt
396

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

Ian Lynagh's avatar
Ian Lynagh committed
400
401
            -- the linkables to link
            linkables = map (expectJust "link".hm_linkable) home_mod_infos
402

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

Ian Lynagh's avatar
Ian Lynagh committed
405
406
407
408
409
        -- 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
410

Ian Lynagh's avatar
Ian Lynagh committed
411
412
        let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
            obj_files = concatMap getOfiles linkables
413

414
            exe_file = exeFileName staticLink dflags
415

416
        linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps
417

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

Ian Lynagh's avatar
Ian Lynagh committed
423
        compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...")
424

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

433
        debugTraceMsg dflags 3 (text "link: done")
434

Ian Lynagh's avatar
Ian Lynagh committed
435
        -- linkBinary only returns if it succeeds
436
437
438
        return Succeeded

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

443

444
linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool
445
linkingNeeded dflags staticLink linkables pkg_deps = do
446
447
448
        -- 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).
449
  let exe_file = exeFileName staticLink dflags
450
  e_exe_time <- tryIO $ getModificationUTCTime exe_file
451
452
453
454
  case e_exe_time of
    Left _  -> return True
    Right t -> do
        -- first check object files and extra_ld_inputs
455
        let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
456
        e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs
457
        let (errs,extra_times) = partitionEithers e_extra_times
458
459
        let obj_times =  map linkableTime linkables ++ extra_times
        if not (null errs) || any (t <) obj_times
Ian Lynagh's avatar
Ian Lynagh committed
460
            then return True
461
462
463
464
            else do

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

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

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

488
489
490
-- -----------------------------------------------------------------------------
-- Compile files in one-shot mode.

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

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

502
   let
Austin Seipp's avatar
Austin Seipp committed
503
        dflags    = hsc_dflags hsc_env
ian@well-typed.com's avatar
ian@well-typed.com committed
504
        split     = gopt Opt_SplitObjs dflags
Ian Lynagh's avatar
Ian Lynagh committed
505
506
        mb_o_file = outputFile dflags
        ghc_link  = ghcLink dflags      -- Set by -c or -no-link
507

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

525
   ( _, out_file) <- runPipeline stop_phase' hsc_env
526
                            (src, fmap RealPhase mb_phase) Nothing output
527
                            Nothing{-no ModLocation-} []
528
529
530
531
532
533
   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
534
  = return ()           -- We stopped before the linking phase
535
536
537

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


545
-- ---------------------------------------------------------------------------
546

547
548
549
550
551
552
553
-- | 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
554
-- OPTIONS_GHC pragmas), and the changes affect later phases in the
555
-- pipeline.
556
runPipeline
557
  :: Phase                      -- ^ When to stop
558
  -> HscEnv                     -- ^ Compilation environment
559
  -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix)
560
  -> Maybe FilePath             -- ^ original basename (if different from ^^^)
Ian Lynagh's avatar
Ian Lynagh committed
561
  -> PipelineOutput             -- ^ Output filename
562
  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
563
  -> [FilePath]                 -- ^ foreign objects
564
  -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)
565
runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
566
             mb_basename output maybe_loc foreign_os
567
568
569
570
571
572
573
574
575
576
577
578
579

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

583
584
585
586
587
588
             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
589
590
591

             isHaskellishFile = isHaskell start_phase

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

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

602
603
604
         -- 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.
605
         let happensBefore' = happensBefore dflags
606
607
         case start_phase of
             RealPhase start_phase' ->
608
609
610
611
                 -- 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)) $
612
613
614
615
                       throwGhcExceptionIO (UsageError
                                   ("cannot compile this file to desired target: "
                                      ++ input_fn))
             HscOut {} -> return ()
616

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

         -- 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
624
         let dflags = hsc_dflags hsc_env
Austin Seipp's avatar
Austin Seipp committed
625
626
627
628
629
630
631
632
         -- 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
633
                                 maybe_loc foreign_os
Austin Seipp's avatar
Austin Seipp committed
634
               return ()
635
636
637
         return r

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

651
  evalP (pipeLoop start_phase input_fn) env state
652

653
654
655
656
-- ---------------------------------------------------------------------------
-- outer pipeline loop

-- | pipeLoop runs phases until we reach the stop phase
657
pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
658
pipeLoop phase input_fn = do
659
  env <- getPipeEnv
660
  dflags <- getDynFlags
661
  -- See Note [Partial ordering on phases]
662
  let happensBefore' = happensBefore dflags
663
      stopPhase = stop_phase env
664
665
  case phase of
   RealPhase realPhase | realPhase `eqPhase` stopPhase            -- All done
666
667
668
669
670
671
     -> -- 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
672
        Temporary _ ->
673
674
675
676
677
678
679
680
681
682
683
684
685
            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)


686
     | not (realPhase `happensBefore'` stopPhase)
Ian Lynagh's avatar
Ian Lynagh committed
687
688
689
690
        -- 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 #-}.
691
     -> panic ("pipeLoop: at phase " ++ show realPhase ++
692
           " but I wanted to stop at phase " ++ show stopPhase)
Ian Lynagh's avatar
Ian Lynagh committed
693

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

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

715
716
717
718
-- -----------------------------------------------------------------------------
-- 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.
719

720
721
722
-- | 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.)
723
724
725
726
727
728
729
730
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

731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
-- | 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?)
746
getOutputFilename
747
748
  :: Phase -> PipelineOutput -> String
  -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
749
getOutputFilename stop_phase output basename dflags next_phase maybe_location
750
751
752
753
754
755
 | 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
756
757
758
 | Temporary lifetime <- output          = newTempName dflags lifetime suffix
 | otherwise                             = newTempName dflags TFL_CurrentModule
   suffix
759
760
761
762
763
764
765
766
767
    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
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
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
                       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
795

Moritz Angermann's avatar
Moritz Angermann committed
796
797

-- | The fast LLVM Pipeline skips the mangler and assembler,
Gabor Greif's avatar
Gabor Greif committed
798
-- emitting object code directly from llc.
Moritz Angermann's avatar
Moritz Angermann committed
799
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
825
826
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
--
-- 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
    ++ [("", "-mcpu=" ++ mcpu)   | not (null mcpu) ]
    ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]

  where target = LLVM_TARGET
        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets dflags)

        -- Relocation models
        rmodel | gopt Opt_PIC dflags        = "pic"
               | positionIndependent dflags = "pic"
               | WayDyn `elem` ways dflags  = "dynamic-no-pic"
               | otherwise                  = "static"

        align :: Int
        align = case platformArch (targetPlatform dflags) of
                  ArchX86_64 | isAvxEnabled dflags -> 32
                  _                                -> 0

        attrs :: String
        attrs = intercalate "," $ mattr
              ++ ["+sse42"   | isSse4_2Enabled dflags   ]
              ++ ["+sse2"    | isSse2Enabled dflags     ]
              ++ ["+sse"     | isSseEnabled dflags      ]
              ++ ["+avx512f" | isAvx512fEnabled dflags  ]
              ++ ["+avx2"    | isAvx2Enabled dflags     ]
              ++ ["+avx"     | isAvxEnabled dflags      ]
              ++ ["+avx512cd"| isAvx512cdEnabled dflags ]
              ++ ["+avx512er"| isAvx512erEnabled dflags ]
              ++ ["+avx512pf"| isAvx512pfEnabled dflags ]
852
853
              ++ ["+bmi"     | isBmiEnabled dflags      ]
              ++ ["+bmi2"    | isBmi2Enabled dflags     ]
Moritz Angermann's avatar
Moritz Angermann committed
854

855
-- -----------------------------------------------------------------------------
856
-- | Each phase in the pipeline returns the next phase to execute, and the
857
858
859
860
861
862
-- 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
863
-- taking the LLVM route to using the native code generator.
864
--
865
runPhase :: PhasePlus   -- ^ Run this phase
866
867
         -> FilePath    -- ^ name of the input file
         -> DynFlags    -- ^ for convenience, we pass the current dflags in
868
         -> CompPipeline (PhasePlus,           -- next phase to run
869
                          FilePath)            -- output filename
Ian Lynagh's avatar
Ian Lynagh committed
870
871
872
873

        -- 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
874

875

876
-------------------------------------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
877
-- Unlit phase
878

879
runPhase (RealPhase (Unlit sf)) input_fn dflags
880
  = do
881
       output_fn <- phaseOutputFilename (Cpp sf)
882

883
       let flags = [ -- The -h option passes the file name for unlit to
884
885
                     -- put in a #line directive
                     SysTools.Option     "-h"
886
887
                     -- See Note [Don't normalise input filenames].
                   , SysTools.Option $ escape input_fn
888
889
890
891
                   , SysTools.FileOption "" input_fn
                   , SysTools.FileOption "" output_fn
                   ]

892
       liftIO $ SysTools.runUnlit dflags flags
893

894
       return (RealPhase (Cpp sf), output_fn)
895
896
897
898
  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
899
       -- Coverage.isGoodTickSrcSpan where we check that the filename in
900
901
       -- a SrcLoc is the same as the source filenaame, the two will
       -- look bogusly different. See test:
902
       -- libraries/hpc/tests/function/subdir/tough2.hs
903
904
905
906
907
       escape ('\\':cs) = '\\':'\\': escape cs
       escape ('\"':cs) = '\\':'\"': escape cs
       escape ('\'':cs) = '\\':'\'': escape cs
       escape (c:cs)    = c : escape cs
       escape []        = []
908
909

-------------------------------------------------------------------------------
910
-- Cpp phase : (a) gets OPTIONS out of file
Ian Lynagh's avatar
Ian Lynagh committed
911
--             (b) runs cpp if necessary
912

913
runPhase (RealPhase (Cpp sf)) input_fn dflags0
914
  = do
915
       src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
916
       (dflags1, unhandled_flags, warns)
917
           <- liftIO $ parseDynamicFilePragma dflags0 src_opts
918
       setDynFlags dflags1
919
       liftIO $ checkProcessArgsResult dflags1 unhandled_flags
920

921
       if not (xopt LangExt.Cpp dflags1) then do
922
           -- we have to be careful to emit warnings only once.
923
924
           unless (gopt Opt_Pp dflags1) $
               liftIO $ handleFlagWarnings dflags1 warns
925

sof's avatar
sof committed
926
           -- no need to preprocess CPP, just pass input file along
Ian Lynagh's avatar
Ian Lynagh committed
927
           -- to the next phase of the pipeline.
928
           return (RealPhase (HsPp sf), input_fn)
Ian Lynagh's avatar
Ian Lynagh committed
929
        else do
930
            output_fn <- phaseOutputFilename (HsPp sf)
931
            liftIO $ doCpp dflags1 True{-raw-}
932
                           input_fn output_fn
933
934
            -- re-read the pragmas now that we've preprocessed the file
            -- See #2464,#3457
935
            src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
936
            (dflags2, unhandled_flags, warns)
937
938
939
940
                <- liftIO $ parseDynamicFilePragma dflags0 src_opts
            liftIO $ checkProcessArgsResult dflags2 unhandled_flags
            unless (gopt Opt_Pp dflags2) $
                liftIO $ handleFlagWarnings dflags2 warns
941
            -- the HsPp pass below will emit warnings
942
943

            setDynFlags dflags2
944

945
            return (RealPhase (HsPp sf), output_fn)
946

sof's avatar
sof committed
947
-------------------------------------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
948
-- HsPp phase
sof's avatar
sof committed
949

950
runPhase (RealPhase (HsPp sf)) input_fn dflags
951
  = do
ian@well-typed.com's avatar
ian@well-typed.com committed
952
       if not (gopt Opt_Pp dflags) then
sof's avatar
sof committed
953
           -- no need to preprocess, just pass input file along
Ian Lynagh's avatar
Ian Lynagh committed
954
           -- to the next phase of the pipeline.
955
          return (RealPhase (Hsc sf), input_fn)
Ian Lynagh's avatar
Ian Lynagh committed
956
        else do
957
958
959
            PipeEnv{src_basename, src_suffix} <- getPipeEnv
            let orig_fn = src_basename <.> src_suffix
            output_fn <- phaseOutputFilename (Hsc sf)
960
            liftIO $ SysTools.runPp dflags
Ian Lynagh's avatar
Ian Lynagh committed
961
962
963
                           ( [ SysTools.Option     orig_fn
                             , SysTools.Option     input_fn
                             , SysTools.FileOption "" output_fn
964
                             ]