839f6d05a48c1b3bef37d0d745bdb65ee223db9c
[ghc.git] / compiler / main / DriverPipeline.hs
1 {-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation #-}
2 {-# OPTIONS_GHC -fno-cse #-}
3 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4
5 -----------------------------------------------------------------------------
6 --
7 -- GHC Driver
8 --
9 -- (c) The University of Glasgow 2005
10 --
11 -----------------------------------------------------------------------------
12
13 module DriverPipeline (
14 -- Run a series of compilation steps in a pipeline, for a
15 -- collection of source files.
16 oneShot, compileFile,
17
18 -- Interfaces for the batch-mode driver
19 linkBinary,
20
21 -- Interfaces for the compilation manager (interpreted/batch-mode)
22 preprocess,
23 compileOne, compileOne',
24 link,
25
26 -- Exports for hooks to override runPhase and link
27 PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),
28 phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,
29 hscPostBackendPhase, getLocation, setModLocation, setDynFlags,
30 runPhase, exeFileName,
31 maybeCreateManifest,
32 linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode
33 ) where
34
35 #include "HsVersions.h"
36
37 import GhcPrelude
38
39 import PipelineMonad
40 import Packages
41 import HeaderInfo
42 import DriverPhases
43 import SysTools
44 import SysTools.ExtraObj
45 import HscMain
46 import Finder
47 import HscTypes hiding ( Hsc )
48 import Outputable
49 import Module
50 import ErrUtils
51 import DynFlags
52 import Config
53 import Panic
54 import Util
55 import StringBuffer ( hGetStringBuffer )
56 import BasicTypes ( SuccessFlag(..) )
57 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
65 import FileCleanup
66 import Ar
67
68 import Exception
69 import System.Directory
70 import System.FilePath
71 import System.IO
72 import Control.Monad
73 import Data.List ( isSuffixOf, intercalate )
74 import Data.Maybe
75 import Data.Version
76
77 -- ---------------------------------------------------------------------------
78 -- Pre-process
79
80 -- | Just preprocess a file, put the result in a temp. file (used by the
81 -- compilation manager during the summary phase).
82 --
83 -- We return the augmented DynFlags, because they contain the result
84 -- of slurping in the OPTIONS pragmas
85
86 preprocess :: HscEnv
87 -> (FilePath, Maybe Phase) -- ^ filename and starting phase
88 -> IO (DynFlags, FilePath)
89 preprocess hsc_env (filename, mb_phase) =
90 ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
91 runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase)
92 Nothing
93 -- We keep the processed file for the whole session to save on
94 -- duplicated work in ghci.
95 (Temporary TFL_GhcSession)
96 Nothing{-no ModLocation-}
97 []{-no foreign objects-}
98
99 -- ---------------------------------------------------------------------------
100
101 -- | Compile
102 --
103 -- Compile a single module, under the control of the compilation manager.
104 --
105 -- This is the interface between the compilation manager and the
106 -- compiler proper (hsc), where we deal with tedious details like
107 -- reading the OPTIONS pragma from the source file, converting the
108 -- C or assembly that GHC produces into an object file, and compiling
109 -- FFI stub files.
110 --
111 -- NB. No old interface can also mean that the source has changed.
112
113 compileOne :: HscEnv
114 -> ModSummary -- ^ summary for module being compiled
115 -> Int -- ^ module N ...
116 -> Int -- ^ ... of M
117 -> Maybe ModIface -- ^ old interface, if we have one
118 -> Maybe Linkable -- ^ old linkable, if we have one
119 -> SourceModified
120 -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful
121
122 compileOne = compileOne' Nothing (Just batchMsg)
123
124 compileOne' :: Maybe TcGblEnv
125 -> Maybe Messager
126 -> HscEnv
127 -> ModSummary -- ^ summary for module being compiled
128 -> Int -- ^ module N ...
129 -> Int -- ^ ... of M
130 -> Maybe ModIface -- ^ old interface, if we have one
131 -> Maybe Linkable -- ^ old linkable, if we have one
132 -> SourceModified
133 -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful
134
135 compileOne' m_tc_result mHscMessage
136 hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
137 source_modified0
138 = do
139
140 debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)
141
142 (status, hmi0) <- hscIncrementalCompile
143 always_do_basic_recompilation_check
144 m_tc_result mHscMessage
145 hsc_env summary source_modified mb_old_iface (mod_index, nmods)
146
147 let flags = hsc_dflags hsc_env0
148 in do unless (gopt Opt_KeepHiFiles flags) $
149 addFilesToClean flags TFL_CurrentModule $
150 [ml_hi_file $ ms_location summary]
151 unless (gopt Opt_KeepOFiles flags) $
152 addFilesToClean flags TFL_GhcSession $
153 [ml_obj_file $ ms_location summary]
154
155 case (status, hsc_lang) of
156 (HscUpToDate, _) ->
157 -- TODO recomp014 triggers this assert. What's going on?!
158 -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )
159 return hmi0 { hm_linkable = maybe_old_linkable }
160 (HscNotGeneratingCode, HscNothing) ->
161 let mb_linkable = if isHsBootOrSig src_flavour
162 then Nothing
163 -- TODO: Questionable.
164 else Just (LM (ms_hs_date summary) this_mod [])
165 in return hmi0 { hm_linkable = mb_linkable }
166 (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode"
167 (_, HscNothing) -> panic "compileOne HscNothing"
168 (HscUpdateBoot, HscInterpreted) -> do
169 return hmi0
170 (HscUpdateBoot, _) -> do
171 touchObjectFile dflags object_filename
172 return hmi0
173 (HscUpdateSig, HscInterpreted) ->
174 let linkable = LM (ms_hs_date summary) this_mod []
175 in return hmi0 { hm_linkable = Just linkable }
176 (HscUpdateSig, _) -> do
177 output_fn <- getOutputFilename next_phase
178 (Temporary TFL_CurrentModule) basename dflags
179 next_phase (Just location)
180
181 -- #10660: Use the pipeline instead of calling
182 -- compileEmptyStub directly, so -dynamic-too gets
183 -- handled properly
184 _ <- runPipeline StopLn hsc_env
185 (output_fn,
186 Just (HscOut src_flavour
187 mod_name HscUpdateSig))
188 (Just basename)
189 Persistent
190 (Just location)
191 []
192 o_time <- getModificationUTCTime object_filename
193 let linkable = LM o_time this_mod [DotO object_filename]
194 return hmi0 { hm_linkable = Just linkable }
195 (HscRecomp cgguts summary, HscInterpreted) -> do
196 (hasStub, comp_bc, spt_entries) <-
197 hscInteractive hsc_env cgguts summary
198
199 stub_o <- case hasStub of
200 Nothing -> return []
201 Just stub_c -> do
202 stub_o <- compileStub hsc_env stub_c
203 return [DotO stub_o]
204
205 let hs_unlinked = [BCOs comp_bc spt_entries]
206 unlinked_time = ms_hs_date summary
207 -- Why do we use the timestamp of the source file here,
208 -- rather than the current time? This works better in
209 -- the case where the local clock is out of sync
210 -- with the filesystem's clock. It's just as accurate:
211 -- if the source is modified, then the linkable will
212 -- be out of date.
213 let linkable = LM unlinked_time (ms_mod summary)
214 (hs_unlinked ++ stub_o)
215 return hmi0 { hm_linkable = Just linkable }
216 (HscRecomp cgguts summary, _) -> do
217 output_fn <- getOutputFilename next_phase
218 (Temporary TFL_CurrentModule)
219 basename dflags next_phase (Just location)
220 -- We're in --make mode: finish the compilation pipeline.
221 _ <- runPipeline StopLn hsc_env
222 (output_fn,
223 Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))
224 (Just basename)
225 Persistent
226 (Just location)
227 []
228 -- The object filename comes from the ModLocation
229 o_time <- getModificationUTCTime object_filename
230 let linkable = LM o_time this_mod [DotO object_filename]
231 return hmi0 { hm_linkable = Just linkable }
232
233 where dflags0 = ms_hspp_opts summary
234
235 this_mod = ms_mod summary
236 location = ms_location summary
237 input_fn = expectJust "compile:hs" (ml_hs_file location)
238 input_fnpp = ms_hspp_file summary
239 mod_graph = hsc_mod_graph hsc_env0
240 needsLinker = needsTemplateHaskellOrQQ mod_graph
241 isDynWay = any (== WayDyn) (ways dflags0)
242 isProfWay = any (== WayProf) (ways dflags0)
243 internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0)
244
245 src_flavour = ms_hsc_src summary
246 mod_name = ms_mod_name summary
247 next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
248 object_filename = ml_obj_file location
249
250 -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
251 -- the linker can correctly load the object files. This isn't necessary
252 -- when using -fexternal-interpreter.
253 dflags1 = if dynamicGhc && internalInterpreter &&
254 not isDynWay && not isProfWay && needsLinker
255 then gopt_set dflags0 Opt_BuildDynamicToo
256 else dflags0
257
258 basename = dropExtension input_fn
259
260 -- We add the directory in which the .hs files resides) to the import
261 -- path. This is needed when we try to compile the .hc file later, if it
262 -- imports a _stub.h file that we created here.
263 current_dir = takeDirectory basename
264 old_paths = includePaths dflags1
265 prevailing_dflags = hsc_dflags hsc_env0
266 dflags =
267 dflags1 { includePaths = addQuoteInclude old_paths [current_dir]
268 , log_action = log_action prevailing_dflags
269 , log_finaliser = log_finaliser prevailing_dflags }
270 -- use the prevailing log_action / log_finaliser,
271 -- not the one cached in the summary. This is so
272 -- that we can change the log_action without having
273 -- to re-summarize all the source files.
274 hsc_env = hsc_env0 {hsc_dflags = dflags}
275
276 -- Figure out what lang we're generating
277 hsc_lang = hscTarget dflags
278
279 -- -fforce-recomp should also work with --make
280 force_recomp = gopt Opt_ForceRecomp dflags
281 source_modified
282 | force_recomp = SourceModified
283 | otherwise = source_modified0
284
285 always_do_basic_recompilation_check = case hsc_lang of
286 HscInterpreted -> True
287 _ -> False
288
289 -----------------------------------------------------------------------------
290 -- stub .h and .c files (for foreign export support), and cc files.
291
292 -- The _stub.c file is derived from the haskell source file, possibly taking
293 -- into account the -stubdir option.
294 --
295 -- The object file created by compiling the _stub.c file is put into a
296 -- temporary file, which will be later combined with the main .o file
297 -- (see the MergeForeigns phase).
298 --
299 -- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files
300 -- from TH, that are then compiled and linked to the module. This is
301 -- useful to implement facilities such as inline-c.
302
303 compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
304 compileForeign hsc_env lang stub_c = do
305 let phase = case lang of
306 LangC -> Cc
307 LangCxx -> Ccxx
308 LangObjc -> Cobjc
309 LangObjcxx -> Cobjcxx
310 (_, stub_o) <- runPipeline StopLn hsc_env
311 (stub_c, Just (RealPhase phase))
312 Nothing (Temporary TFL_GhcSession)
313 Nothing{-no ModLocation-}
314 []
315 return stub_o
316
317 compileStub :: HscEnv -> FilePath -> IO FilePath
318 compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c
319
320 compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
321 compileEmptyStub dflags hsc_env basename location mod_name = do
322 -- To maintain the invariant that every Haskell file
323 -- compiles to object code, we make an empty (but
324 -- valid) stub object file for signatures. However,
325 -- we make sure this object file has a unique symbol,
326 -- so that ranlib on OS X doesn't complain, see
327 -- http://ghc.haskell.org/trac/ghc/ticket/12673
328 -- and https://github.com/haskell/cabal/issues/2257
329 empty_stub <- newTempName dflags TFL_CurrentModule "c"
330 let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;"
331 writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
332 _ <- runPipeline StopLn hsc_env
333 (empty_stub, Nothing)
334 (Just basename)
335 Persistent
336 (Just location)
337 []
338 return ()
339
340 -- ---------------------------------------------------------------------------
341 -- Link
342
343 link :: GhcLink -- interactive or batch
344 -> DynFlags -- dynamic flags
345 -> Bool -- attempt linking in batch mode?
346 -> HomePackageTable -- what to link
347 -> IO SuccessFlag
348
349 -- For the moment, in the batch linker, we don't bother to tell doLink
350 -- which packages to link -- it just tries all that are available.
351 -- batch_attempt_linking should only be *looked at* in batch mode. It
352 -- should only be True if the upsweep was successful and someone
353 -- exports main, i.e., we have good reason to believe that linking
354 -- will succeed.
355
356 link ghcLink dflags
357 = lookupHook linkHook l dflags ghcLink dflags
358 where
359 l LinkInMemory _ _ _
360 = if cGhcWithInterpreter == "YES"
361 then -- Not Linking...(demand linker will do the job)
362 return Succeeded
363 else panicBadLink LinkInMemory
364
365 l NoLink _ _ _
366 = return Succeeded
367
368 l LinkBinary dflags batch_attempt_linking hpt
369 = link' dflags batch_attempt_linking hpt
370
371 l LinkStaticLib dflags batch_attempt_linking hpt
372 = link' dflags batch_attempt_linking hpt
373
374 l LinkDynLib dflags batch_attempt_linking hpt
375 = link' dflags batch_attempt_linking hpt
376
377 panicBadLink :: GhcLink -> a
378 panicBadLink other = panic ("link: GHC not built to link this way: " ++
379 show other)
380
381 link' :: DynFlags -- dynamic flags
382 -> Bool -- attempt linking in batch mode?
383 -> HomePackageTable -- what to link
384 -> IO SuccessFlag
385
386 link' dflags batch_attempt_linking hpt
387 | batch_attempt_linking
388 = do
389 let
390 staticLink = case ghcLink dflags of
391 LinkStaticLib -> True
392 _ -> False
393
394 home_mod_infos = eltsHpt hpt
395
396 -- the packages we depend on
397 pkg_deps = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos
398
399 -- the linkables to link
400 linkables = map (expectJust "link".hm_linkable) home_mod_infos
401
402 debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
403
404 -- check for the -no-link flag
405 if isNoLink (ghcLink dflags)
406 then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).")
407 return Succeeded
408 else do
409
410 let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
411 obj_files = concatMap getOfiles linkables
412
413 exe_file = exeFileName staticLink dflags
414
415 linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps
416
417 if not (gopt Opt_ForceRecomp dflags) && not linking_needed
418 then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.")
419 return Succeeded
420 else do
421
422 compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...")
423
424 -- Don't showPass in Batch mode; doLink will do that for us.
425 let link = case ghcLink dflags of
426 LinkBinary -> linkBinary
427 LinkStaticLib -> linkStaticLib
428 LinkDynLib -> linkDynLibCheck
429 other -> panicBadLink other
430 link dflags obj_files pkg_deps
431
432 debugTraceMsg dflags 3 (text "link: done")
433
434 -- linkBinary only returns if it succeeds
435 return Succeeded
436
437 | otherwise
438 = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$
439 text " Main.main not exported; not linking.")
440 return Succeeded
441
442
443 linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool
444 linkingNeeded dflags staticLink linkables pkg_deps = do
445 -- if the modification time on the executable is later than the
446 -- modification times on all of the objects and libraries, then omit
447 -- linking (unless the -fforce-recomp flag was given).
448 let exe_file = exeFileName staticLink dflags
449 e_exe_time <- tryIO $ getModificationUTCTime exe_file
450 case e_exe_time of
451 Left _ -> return True
452 Right t -> do
453 -- first check object files and extra_ld_inputs
454 let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
455 e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs
456 let (errs,extra_times) = splitEithers e_extra_times
457 let obj_times = map linkableTime linkables ++ extra_times
458 if not (null errs) || any (t <) obj_times
459 then return True
460 else do
461
462 -- next, check libraries. XXX this only checks Haskell libraries,
463 -- not extra_libraries or -l things from the command line.
464 let pkg_hslibs = [ (collectLibraryPaths dflags [c], lib)
465 | Just c <- map (lookupInstalledPackage dflags) pkg_deps,
466 lib <- packageHsLibs dflags c ]
467
468 pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs
469 if any isNothing pkg_libfiles then return True else do
470 e_lib_times <- mapM (tryIO . getModificationUTCTime)
471 (catMaybes pkg_libfiles)
472 let (lib_errs,lib_times) = splitEithers e_lib_times
473 if not (null lib_errs) || any (t <) lib_times
474 then return True
475 else checkLinkInfo dflags pkg_deps exe_file
476
477 findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath)
478 findHSLib dflags dirs lib = do
479 let batch_lib_file = if WayDyn `notElem` ways dflags
480 then "lib" ++ lib <.> "a"
481 else mkSOName (targetPlatform dflags) lib
482 found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
483 case found of
484 [] -> return Nothing
485 (x:_) -> return (Just x)
486
487 -- -----------------------------------------------------------------------------
488 -- Compile files in one-shot mode.
489
490 oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
491 oneShot hsc_env stop_phase srcs = do
492 o_files <- mapM (compileFile hsc_env stop_phase) srcs
493 doLink (hsc_dflags hsc_env) stop_phase o_files
494
495 compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
496 compileFile hsc_env stop_phase (src, mb_phase) = do
497 exists <- doesFileExist src
498 when (not exists) $
499 throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))
500
501 let
502 dflags = hsc_dflags hsc_env
503 split = gopt Opt_SplitObjs dflags
504 mb_o_file = outputFile dflags
505 ghc_link = ghcLink dflags -- Set by -c or -no-link
506
507 -- When linking, the -o argument refers to the linker's output.
508 -- otherwise, we use it as the name for the pipeline's output.
509 output
510 -- If we are doing -fno-code, then act as if the output is
511 -- 'Temporary'. This stops GHC trying to copy files to their
512 -- final location.
513 | HscNothing <- hscTarget dflags = Temporary TFL_CurrentModule
514 | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
515 -- -o foo applies to linker
516 | isJust mb_o_file = SpecificFile
517 -- -o foo applies to the file we are compiling now
518 | otherwise = Persistent
519
520 stop_phase' = case stop_phase of
521 As _ | split -> SplitAs
522 _ -> stop_phase
523
524 ( _, out_file) <- runPipeline stop_phase' hsc_env
525 (src, fmap RealPhase mb_phase) Nothing output
526 Nothing{-no ModLocation-} []
527 return out_file
528
529
530 doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
531 doLink dflags stop_phase o_files
532 | not (isStopLn stop_phase)
533 = return () -- We stopped before the linking phase
534
535 | otherwise
536 = case ghcLink dflags of
537 NoLink -> return ()
538 LinkBinary -> linkBinary dflags o_files []
539 LinkStaticLib -> linkStaticLib dflags o_files []
540 LinkDynLib -> linkDynLibCheck dflags o_files []
541 other -> panicBadLink other
542
543
544 -- ---------------------------------------------------------------------------
545
546 -- | Run a compilation pipeline, consisting of multiple phases.
547 --
548 -- This is the interface to the compilation pipeline, which runs
549 -- a series of compilation steps on a single source file, specifying
550 -- at which stage to stop.
551 --
552 -- The DynFlags can be modified by phases in the pipeline (eg. by
553 -- OPTIONS_GHC pragmas), and the changes affect later phases in the
554 -- pipeline.
555 runPipeline
556 :: Phase -- ^ When to stop
557 -> HscEnv -- ^ Compilation environment
558 -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix)
559 -> Maybe FilePath -- ^ original basename (if different from ^^^)
560 -> PipelineOutput -- ^ Output filename
561 -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
562 -> [FilePath] -- ^ foreign objects
563 -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
564 runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
565 mb_basename output maybe_loc foreign_os
566
567 = do let
568 dflags0 = hsc_dflags hsc_env0
569
570 -- Decide where dump files should go based on the pipeline output
571 dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
572 hsc_env = hsc_env0 {hsc_dflags = dflags}
573
574 (input_basename, suffix) = splitExtension input_fn
575 suffix' = drop 1 suffix -- strip off the .
576 basename | Just b <- mb_basename = b
577 | otherwise = input_basename
578
579 -- If we were given a -x flag, then use that phase to start from
580 start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase
581
582 isHaskell (RealPhase (Unlit _)) = True
583 isHaskell (RealPhase (Cpp _)) = True
584 isHaskell (RealPhase (HsPp _)) = True
585 isHaskell (RealPhase (Hsc _)) = True
586 isHaskell (HscOut {}) = True
587 isHaskell _ = False
588
589 isHaskellishFile = isHaskell start_phase
590
591 env = PipeEnv{ stop_phase,
592 src_filename = input_fn,
593 src_basename = basename,
594 src_suffix = suffix',
595 output_spec = output }
596
597 when (isBackpackishSuffix suffix') $
598 throwGhcExceptionIO (UsageError
599 ("use --backpack to process " ++ input_fn))
600
601 -- We want to catch cases of "you can't get there from here" before
602 -- we start the pipeline, because otherwise it will just run off the
603 -- end.
604 let happensBefore' = happensBefore dflags
605 case start_phase of
606 RealPhase start_phase' ->
607 -- See Note [Partial ordering on phases]
608 -- Not the same as: (stop_phase `happensBefore` start_phase')
609 when (not (start_phase' `happensBefore'` stop_phase ||
610 start_phase' `eqPhase` stop_phase)) $
611 throwGhcExceptionIO (UsageError
612 ("cannot compile this file to desired target: "
613 ++ input_fn))
614 HscOut {} -> return ()
615
616 debugTraceMsg dflags 4 (text "Running the pipeline")
617 r <- runPipeline' start_phase hsc_env env input_fn
618 maybe_loc foreign_os
619
620 -- If we are compiling a Haskell module, and doing
621 -- -dynamic-too, but couldn't do the -dynamic-too fast
622 -- path, then rerun the pipeline for the dyn way
623 let dflags = hsc_dflags hsc_env
624 -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)
625 when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do
626 when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do
627 debugTraceMsg dflags 4
628 (text "Running the pipeline again for -dynamic-too")
629 let dflags' = dynamicTooMkDynamicDynFlags dflags
630 hsc_env' <- newHscEnv dflags'
631 _ <- runPipeline' start_phase hsc_env' env input_fn
632 maybe_loc foreign_os
633 return ()
634 return r
635
636 runPipeline'
637 :: PhasePlus -- ^ When to start
638 -> HscEnv -- ^ Compilation environment
639 -> PipeEnv
640 -> FilePath -- ^ Input filename
641 -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
642 -> [FilePath] -- ^ foreign objects, if we have one
643 -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
644 runPipeline' start_phase hsc_env env input_fn
645 maybe_loc foreign_os
646 = do
647 -- Execute the pipeline...
648 let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os }
649
650 evalP (pipeLoop start_phase input_fn) env state
651
652 -- ---------------------------------------------------------------------------
653 -- outer pipeline loop
654
655 -- | pipeLoop runs phases until we reach the stop phase
656 pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
657 pipeLoop phase input_fn = do
658 env <- getPipeEnv
659 dflags <- getDynFlags
660 -- See Note [Partial ordering on phases]
661 let happensBefore' = happensBefore dflags
662 stopPhase = stop_phase env
663 case phase of
664 RealPhase realPhase | realPhase `eqPhase` stopPhase -- All done
665 -> -- Sometimes, a compilation phase doesn't actually generate any output
666 -- (eg. the CPP phase when -fcpp is not turned on). If we end on this
667 -- stage, but we wanted to keep the output, then we have to explicitly
668 -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
669 -- further compilation stages can tell what the original filename was.
670 case output_spec env of
671 Temporary _ ->
672 return (dflags, input_fn)
673 output ->
674 do pst <- getPipeState
675 final_fn <- liftIO $ getOutputFilename
676 stopPhase output (src_basename env)
677 dflags stopPhase (maybe_loc pst)
678 when (final_fn /= input_fn) $ do
679 let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")
680 line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")
681 liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn
682 return (dflags, final_fn)
683
684
685 | not (realPhase `happensBefore'` stopPhase)
686 -- Something has gone wrong. We'll try to cover all the cases when
687 -- this could happen, so if we reach here it is a panic.
688 -- eg. it might happen if the -C flag is used on a source file that
689 -- has {-# OPTIONS -fasm #-}.
690 -> panic ("pipeLoop: at phase " ++ show realPhase ++
691 " but I wanted to stop at phase " ++ show stopPhase)
692
693 _
694 -> do liftIO $ debugTraceMsg dflags 4
695 (text "Running phase" <+> ppr phase)
696 (next_phase, output_fn) <- runHookedPhase phase input_fn dflags
697 r <- pipeLoop next_phase output_fn
698 case phase of
699 HscOut {} ->
700 whenGeneratingDynamicToo dflags $ do
701 setDynFlags $ dynamicTooMkDynamicDynFlags dflags
702 -- TODO shouldn't ignore result:
703 _ <- pipeLoop phase input_fn
704 return ()
705 _ ->
706 return ()
707 return r
708
709 runHookedPhase :: PhasePlus -> FilePath -> DynFlags
710 -> CompPipeline (PhasePlus, FilePath)
711 runHookedPhase pp input dflags =
712 lookupHook runPhaseHook runPhase dflags pp input dflags
713
714 -- -----------------------------------------------------------------------------
715 -- In each phase, we need to know into what filename to generate the
716 -- output. All the logic about which filenames we generate output
717 -- into is embodied in the following function.
718
719 -- | Computes the next output filename after we run @next_phase@.
720 -- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad
721 -- (which specifies all of the ambient information.)
722 phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
723 phaseOutputFilename next_phase = do
724 PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
725 PipeState{maybe_loc, hsc_env} <- getPipeState
726 let dflags = hsc_dflags hsc_env
727 liftIO $ getOutputFilename stop_phase output_spec
728 src_basename dflags next_phase maybe_loc
729
730 -- | Computes the next output filename for something in the compilation
731 -- pipeline. This is controlled by several variables:
732 --
733 -- 1. 'Phase': the last phase to be run (e.g. 'stopPhase'). This
734 -- is used to tell if we're in the last phase or not, because
735 -- in that case flags like @-o@ may be important.
736 -- 2. 'PipelineOutput': is this intended to be a 'Temporary' or
737 -- 'Persistent' build output? Temporary files just go in
738 -- a fresh temporary name.
739 -- 3. 'String': what was the basename of the original input file?
740 -- 4. 'DynFlags': the obvious thing
741 -- 5. 'Phase': the phase we want to determine the output filename of.
742 -- 6. @Maybe ModLocation@: the 'ModLocation' of the module we're
743 -- compiling; this can be used to override the default output
744 -- of an object file. (TODO: do we actually need this?)
745 getOutputFilename
746 :: Phase -> PipelineOutput -> String
747 -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
748 getOutputFilename stop_phase output basename dflags next_phase maybe_location
749 | is_last_phase, Persistent <- output = persistent_fn
750 | is_last_phase, SpecificFile <- output = case outputFile dflags of
751 Just f -> return f
752 Nothing ->
753 panic "SpecificFile: No filename"
754 | keep_this_output = persistent_fn
755 | Temporary lifetime <- output = newTempName dflags lifetime suffix
756 | otherwise = newTempName dflags TFL_CurrentModule
757 suffix
758 where
759 hcsuf = hcSuf dflags
760 odir = objectDir dflags
761 osuf = objectSuf dflags
762 keep_hc = gopt Opt_KeepHcFiles dflags
763 keep_s = gopt Opt_KeepSFiles dflags
764 keep_bc = gopt Opt_KeepLlvmFiles dflags
765
766 myPhaseInputExt HCc = hcsuf
767 myPhaseInputExt MergeForeign = osuf
768 myPhaseInputExt StopLn = osuf
769 myPhaseInputExt other = phaseInputExt other
770
771 is_last_phase = next_phase `eqPhase` stop_phase
772
773 -- sometimes, we keep output from intermediate stages
774 keep_this_output =
775 case next_phase of
776 As _ | keep_s -> True
777 LlvmOpt | keep_bc -> True
778 HCc | keep_hc -> True
779 _other -> False
780
781 suffix = myPhaseInputExt next_phase
782
783 -- persistent object files get put in odir
784 persistent_fn
785 | StopLn <- next_phase = return odir_persistent
786 | otherwise = return persistent
787
788 persistent = basename <.> suffix
789
790 odir_persistent
791 | Just loc <- maybe_location = ml_obj_file loc
792 | Just d <- odir = d </> persistent
793 | otherwise = persistent
794
795
796 -- | The fast LLVM Pipeline skips the mangler and assembler,
797 -- emitting object code directly from llc.
798 --
799 -- slow: opt -> llc -> .s -> mangler -> as -> .o
800 -- fast: opt -> llc -> .o
801 --
802 -- hidden flag: -ffast-llvm
803 --
804 -- if keep-s-files is specified, we need to go through
805 -- the slow pipeline (Kavon Farvardin requested this).
806 fastLlvmPipeline :: DynFlags -> Bool
807 fastLlvmPipeline dflags
808 = not (gopt Opt_KeepSFiles dflags) && gopt Opt_FastLlvm dflags
809
810 -- | LLVM Options. These are flags to be passed to opt and llc, to ensure
811 -- consistency we list them in pairs, so that they form groups.
812 llvmOptions :: DynFlags
813 -> [(String, String)] -- ^ pairs of (opt, llc) arguments
814 llvmOptions dflags =
815 [("-enable-tbaa -tbaa", "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]
816 ++ [("-relocation-model=" ++ rmodel
817 ,"-relocation-model=" ++ rmodel) | not (null rmodel)]
818 ++ [("-stack-alignment=" ++ (show align)
819 ,"-stack-alignment=" ++ (show align)) | align > 0 ]
820 ++ [("", "-filetype=obj") | fastLlvmPipeline dflags ]
821
822 -- Additional llc flags
823 ++ [("", "-mcpu=" ++ mcpu) | not (null mcpu) ]
824 ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]
825
826 where target = LLVM_TARGET
827 Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets dflags)
828
829 -- Relocation models
830 rmodel | gopt Opt_PIC dflags = "pic"
831 | positionIndependent dflags = "pic"
832 | WayDyn `elem` ways dflags = "dynamic-no-pic"
833 | otherwise = "static"
834
835 align :: Int
836 align = case platformArch (targetPlatform dflags) of
837 ArchX86_64 | isAvxEnabled dflags -> 32
838 _ -> 0
839
840 attrs :: String
841 attrs = intercalate "," $ mattr
842 ++ ["+sse42" | isSse4_2Enabled dflags ]
843 ++ ["+sse2" | isSse2Enabled dflags ]
844 ++ ["+sse" | isSseEnabled dflags ]
845 ++ ["+avx512f" | isAvx512fEnabled dflags ]
846 ++ ["+avx2" | isAvx2Enabled dflags ]
847 ++ ["+avx" | isAvxEnabled dflags ]
848 ++ ["+avx512cd"| isAvx512cdEnabled dflags ]
849 ++ ["+avx512er"| isAvx512erEnabled dflags ]
850 ++ ["+avx512pf"| isAvx512pfEnabled dflags ]
851 ++ ["+bmi" | isBmiEnabled dflags ]
852 ++ ["+bmi2" | isBmi2Enabled dflags ]
853
854 -- -----------------------------------------------------------------------------
855 -- | Each phase in the pipeline returns the next phase to execute, and the
856 -- name of the file in which the output was placed.
857 --
858 -- We must do things dynamically this way, because we often don't know
859 -- what the rest of the phases will be until part-way through the
860 -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
861 -- of a source file can change the latter stages of the pipeline from
862 -- taking the LLVM route to using the native code generator.
863 --
864 runPhase :: PhasePlus -- ^ Run this phase
865 -> FilePath -- ^ name of the input file
866 -> DynFlags -- ^ for convenience, we pass the current dflags in
867 -> CompPipeline (PhasePlus, -- next phase to run
868 FilePath) -- output filename
869
870 -- Invariant: the output filename always contains the output
871 -- Interesting case: Hsc when there is no recompilation to do
872 -- Then the output filename is still a .o file
873
874
875 -------------------------------------------------------------------------------
876 -- Unlit phase
877
878 runPhase (RealPhase (Unlit sf)) input_fn dflags
879 = do
880 output_fn <- phaseOutputFilename (Cpp sf)
881
882 let flags = [ -- The -h option passes the file name for unlit to
883 -- put in a #line directive
884 SysTools.Option "-h"
885 -- See Note [Don't normalise input filenames].
886 , SysTools.Option $ escape input_fn
887 , SysTools.FileOption "" input_fn
888 , SysTools.FileOption "" output_fn
889 ]
890
891 liftIO $ SysTools.runUnlit dflags flags
892
893 return (RealPhase (Cpp sf), output_fn)
894 where
895 -- escape the characters \, ", and ', but don't try to escape
896 -- Unicode or anything else (so we don't use Util.charToC
897 -- here). If we get this wrong, then in
898 -- Coverage.isGoodTickSrcSpan where we check that the filename in
899 -- a SrcLoc is the same as the source filenaame, the two will
900 -- look bogusly different. See test:
901 -- libraries/hpc/tests/function/subdir/tough2.hs
902 escape ('\\':cs) = '\\':'\\': escape cs
903 escape ('\"':cs) = '\\':'\"': escape cs
904 escape ('\'':cs) = '\\':'\'': escape cs
905 escape (c:cs) = c : escape cs
906 escape [] = []
907
908 -------------------------------------------------------------------------------
909 -- Cpp phase : (a) gets OPTIONS out of file
910 -- (b) runs cpp if necessary
911
912 runPhase (RealPhase (Cpp sf)) input_fn dflags0
913 = do
914 src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
915 (dflags1, unhandled_flags, warns)
916 <- liftIO $ parseDynamicFilePragma dflags0 src_opts
917 setDynFlags dflags1
918 liftIO $ checkProcessArgsResult dflags1 unhandled_flags
919
920 if not (xopt LangExt.Cpp dflags1) then do
921 -- we have to be careful to emit warnings only once.
922 unless (gopt Opt_Pp dflags1) $
923 liftIO $ handleFlagWarnings dflags1 warns
924
925 -- no need to preprocess CPP, just pass input file along
926 -- to the next phase of the pipeline.
927 return (RealPhase (HsPp sf), input_fn)
928 else do
929 output_fn <- phaseOutputFilename (HsPp sf)
930 liftIO $ doCpp dflags1 True{-raw-}
931 input_fn output_fn
932 -- re-read the pragmas now that we've preprocessed the file
933 -- See #2464,#3457
934 src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
935 (dflags2, unhandled_flags, warns)
936 <- liftIO $ parseDynamicFilePragma dflags0 src_opts
937 liftIO $ checkProcessArgsResult dflags2 unhandled_flags
938 unless (gopt Opt_Pp dflags2) $
939 liftIO $ handleFlagWarnings dflags2 warns
940 -- the HsPp pass below will emit warnings
941
942 setDynFlags dflags2
943
944 return (RealPhase (HsPp sf), output_fn)
945
946 -------------------------------------------------------------------------------
947 -- HsPp phase
948
949 runPhase (RealPhase (HsPp sf)) input_fn dflags
950 = do
951 if not (gopt Opt_Pp dflags) then
952 -- no need to preprocess, just pass input file along
953 -- to the next phase of the pipeline.
954 return (RealPhase (Hsc sf), input_fn)
955 else do
956 PipeEnv{src_basename, src_suffix} <- getPipeEnv
957 let orig_fn = src_basename <.> src_suffix
958 output_fn <- phaseOutputFilename (Hsc sf)
959 liftIO $ SysTools.runPp dflags
960 ( [ SysTools.Option orig_fn
961 , SysTools.Option input_fn
962 , SysTools.FileOption "" output_fn
963 ]
964 )
965
966 -- re-read pragmas now that we've parsed the file (see #3674)
967 src_opts <- liftIO $ getOptionsFromFile dflags output_fn
968 (dflags1, unhandled_flags, warns)
969 <- liftIO $ parseDynamicFilePragma dflags src_opts
970 setDynFlags dflags1
971 liftIO $ checkProcessArgsResult dflags1 unhandled_flags
972 liftIO $ handleFlagWarnings dflags1 warns
973
974 return (RealPhase (Hsc sf), output_fn)
975
976 -----------------------------------------------------------------------------
977 -- Hsc phase
978
979 -- Compilation of a single module, in "legacy" mode (_not_ under
980 -- the direction of the compilation manager).
981 runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
982 = do -- normal Hsc mode, not mkdependHS
983
984 PipeEnv{ stop_phase=stop,
985 src_basename=basename,
986 src_suffix=suff } <- getPipeEnv
987
988 -- we add the current directory (i.e. the directory in which
989 -- the .hs files resides) to the include path, since this is
990 -- what gcc does, and it's probably what you want.
991 let current_dir = takeDirectory basename
992 new_includes = addQuoteInclude paths [current_dir]
993 paths = includePaths dflags0
994 dflags = dflags0 { includePaths = new_includes }
995
996 setDynFlags dflags
997
998 -- gather the imports and module name
999 (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do
1000 do
1001 buf <- hGetStringBuffer input_fn
1002 (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
1003 return (Just buf, mod_name, imps, src_imps)
1004
1005 -- Take -o into account if present
1006 -- Very like -ohi, but we must *only* do this if we aren't linking
1007 -- (If we're linking then the -o applies to the linked thing, not to
1008 -- the object file for one module.)
1009 -- Note the nasty duplication with the same computation in compileFile above
1010 location <- getLocation src_flavour mod_name
1011
1012 let o_file = ml_obj_file location -- The real object file
1013 hi_file = ml_hi_file location
1014 dest_file | writeInterfaceOnlyMode dflags
1015 = hi_file
1016 | otherwise
1017 = o_file
1018
1019 -- Figure out if the source has changed, for recompilation avoidance.
1020 --
1021 -- Setting source_unchanged to True means that M.o seems
1022 -- to be up to date wrt M.hs; so no need to recompile unless imports have
1023 -- changed (which the compiler itself figures out).
1024 -- Setting source_unchanged to False tells the compiler that M.o is out of
1025 -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
1026 src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)
1027
1028 source_unchanged <- liftIO $
1029 if not (isStopLn stop)
1030 -- SourceModified unconditionally if
1031 -- (a) recompilation checker is off, or
1032 -- (b) we aren't going all the way to .o file (e.g. ghc -S)
1033 then return SourceModified
1034 -- Otherwise look at file modification dates
1035 else do dest_file_exists <- doesFileExist dest_file
1036 if not dest_file_exists
1037 then return SourceModified -- Need to recompile
1038 else do t2 <- getModificationUTCTime dest_file
1039 if t2 > src_timestamp
1040 then return SourceUnmodified
1041 else return SourceModified
1042
1043 PipeState{hsc_env=hsc_env'} <- getPipeState
1044
1045 -- Tell the finder cache about this module
1046 mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location
1047
1048 -- Make the ModSummary to hand to hscMain
1049 let
1050 mod_summary = ModSummary { ms_mod = mod,
1051 ms_hsc_src = src_flavour,
1052 ms_hspp_file = input_fn,
1053 ms_hspp_opts = dflags,
1054 ms_hspp_buf = hspp_buf,
1055 ms_location = location,
1056 ms_hs_date = src_timestamp,
1057 ms_obj_date = Nothing,
1058 ms_parsed_mod = Nothing,
1059 ms_iface_date = Nothing,
1060 ms_textual_imps = imps,
1061 ms_srcimps = src_imps }
1062
1063 -- run the compiler!
1064 let msg hsc_env _ what _ = oneShotMsg hsc_env what
1065 (result, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'
1066 mod_summary source_unchanged Nothing (1,1)
1067
1068 return (HscOut src_flavour mod_name result,
1069 panic "HscOut doesn't have an input filename")
1070
1071 runPhase (HscOut src_flavour mod_name result) _ dflags = do
1072 location <- getLocation src_flavour mod_name
1073 setModLocation location
1074
1075 let o_file = ml_obj_file location -- The real object file
1076 hsc_lang = hscTarget dflags
1077 next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
1078
1079 case result of
1080 HscNotGeneratingCode ->
1081 return (RealPhase StopLn,
1082 panic "No output filename from Hsc when no-code")
1083 HscUpToDate ->
1084 do liftIO $ touchObjectFile dflags o_file
1085 -- The .o file must have a later modification date
1086 -- than the source file (else we wouldn't get Nothing)
1087 -- but we touch it anyway, to keep 'make' happy (we think).
1088 return (RealPhase StopLn, o_file)
1089 HscUpdateBoot ->
1090 do -- In the case of hs-boot files, generate a dummy .o-boot
1091 -- stamp file for the benefit of Make
1092 liftIO $ touchObjectFile dflags o_file
1093 return (RealPhase StopLn, o_file)
1094 HscUpdateSig ->
1095 do -- We need to create a REAL but empty .o file
1096 -- because we are going to attempt to put it in a library
1097 PipeState{hsc_env=hsc_env'} <- getPipeState
1098 let input_fn = expectJust "runPhase" (ml_hs_file location)
1099 basename = dropExtension input_fn
1100 liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name
1101 return (RealPhase StopLn, o_file)
1102 HscRecomp cgguts mod_summary
1103 -> do output_fn <- phaseOutputFilename next_phase
1104
1105 PipeState{hsc_env=hsc_env'} <- getPipeState
1106
1107 (outputFilename, mStub, foreign_files) <- liftIO $
1108 hscGenHardCode hsc_env' cgguts mod_summary output_fn
1109 stub_o <- liftIO (mapM (compileStub hsc_env') mStub)
1110 foreign_os <- liftIO $
1111 mapM (uncurry (compileForeign hsc_env')) foreign_files
1112 setForeignOs (maybe [] return stub_o ++ foreign_os)
1113
1114 return (RealPhase next_phase, outputFilename)
1115
1116 -----------------------------------------------------------------------------
1117 -- Cmm phase
1118
1119 runPhase (RealPhase CmmCpp) input_fn dflags
1120 = do
1121 output_fn <- phaseOutputFilename Cmm
1122 liftIO $ doCpp dflags False{-not raw-}
1123 input_fn output_fn
1124 return (RealPhase Cmm, output_fn)
1125
1126 runPhase (RealPhase Cmm) input_fn dflags
1127 = do
1128 let hsc_lang = hscTarget dflags
1129
1130 let next_phase = hscPostBackendPhase dflags HsSrcFile hsc_lang
1131
1132 output_fn <- phaseOutputFilename next_phase
1133
1134 PipeState{hsc_env} <- getPipeState
1135
1136 liftIO $ hscCompileCmmFile hsc_env input_fn output_fn
1137
1138 return (RealPhase next_phase, output_fn)
1139
1140 -----------------------------------------------------------------------------
1141 -- Cc phase
1142
1143 -- we don't support preprocessing .c files (with -E) now. Doing so introduces
1144 -- way too many hacks, and I can't say I've ever used it anyway.
1145
1146 runPhase (RealPhase cc_phase) input_fn dflags
1147 | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx]
1148 = do
1149 let platform = targetPlatform dflags
1150 hcc = cc_phase `eqPhase` HCc
1151
1152 let cmdline_include_paths = includePaths dflags
1153
1154 -- HC files have the dependent packages stamped into them
1155 pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return []
1156
1157 -- add package include paths even if we're just compiling .c
1158 -- files; this is the Value Add(TM) that using ghc instead of
1159 -- gcc gives you :)
1160 pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
1161 let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
1162 (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
1163 let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
1164 (includePathsQuote cmdline_include_paths)
1165 let include_paths = include_paths_quote ++ include_paths_global
1166
1167 let gcc_extra_viac_flags = extraGccViaCFlags dflags
1168 let pic_c_flags = picCCOpts dflags
1169
1170 let verbFlags = getVerbFlags dflags
1171
1172 -- cc-options are not passed when compiling .hc files. Our
1173 -- hc code doesn't not #include any header files anyway, so these
1174 -- options aren't necessary.
1175 pkg_extra_cc_opts <- liftIO $
1176 if cc_phase `eqPhase` HCc
1177 then return []
1178 else getPackageExtraCcOpts dflags pkgs
1179
1180 framework_paths <-
1181 if platformUsesFrameworks platform
1182 then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs
1183 let cmdlineFrameworkPaths = frameworkPaths dflags
1184 return $ map ("-F"++)
1185 (cmdlineFrameworkPaths ++ pkgFrameworkPaths)
1186 else return []
1187
1188 let cc_opt | optLevel dflags >= 2 = [ "-O2" ]
1189 | optLevel dflags >= 1 = [ "-O" ]
1190 | otherwise = []
1191
1192 -- Decide next phase
1193 let next_phase = As False
1194 output_fn <- phaseOutputFilename next_phase
1195
1196 let
1197 more_hcc_opts =
1198 -- on x86 the floating point regs have greater precision
1199 -- than a double, which leads to unpredictable results.
1200 -- By default, we turn this off with -ffloat-store unless
1201 -- the user specified -fexcess-precision.
1202 (if platformArch platform == ArchX86 &&
1203 not (gopt Opt_ExcessPrecision dflags)
1204 then [ "-ffloat-store" ]
1205 else []) ++
1206
1207 -- gcc's -fstrict-aliasing allows two accesses to memory
1208 -- to be considered non-aliasing if they have different types.
1209 -- This interacts badly with the C code we generate, which is
1210 -- very weakly typed, being derived from C--.
1211 ["-fno-strict-aliasing"]
1212
1213 ghcVersionH <- liftIO $ getGhcVersionPathName dflags
1214
1215 let gcc_lang_opt | cc_phase `eqPhase` Ccxx = "c++"
1216 | cc_phase `eqPhase` Cobjc = "objective-c"
1217 | cc_phase `eqPhase` Cobjcxx = "objective-c++"
1218 | otherwise = "c"
1219 liftIO $ SysTools.runCc dflags (
1220 -- force the C compiler to interpret this file as C when
1221 -- compiling .hc files, by adding the -x c option.
1222 -- Also useful for plain .c files, just in case GHC saw a
1223 -- -x c option.
1224 [ SysTools.Option "-x", SysTools.Option gcc_lang_opt
1225 , SysTools.FileOption "" input_fn
1226 , SysTools.Option "-o"
1227 , SysTools.FileOption "" output_fn
1228 ]
1229 ++ map SysTools.Option (
1230 pic_c_flags
1231
1232 -- Stub files generated for foreign exports references the runIO_closure
1233 -- and runNonIO_closure symbols, which are defined in the base package.
1234 -- These symbols are imported into the stub.c file via RtsAPI.h, and the
1235 -- way we do the import depends on whether we're currently compiling
1236 -- the base package or not.
1237 ++ (if platformOS platform == OSMinGW32 &&
1238 thisPackage dflags == baseUnitId
1239 then [ "-DCOMPILING_BASE_PACKAGE" ]
1240 else [])
1241
1242 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1243 -- instruction. Note that the user can still override this
1244 -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
1245 -- regardless of the ordering.
1246 --
1247 -- This is a temporary hack. See #2872, commit
1248 -- 5bd3072ac30216a505151601884ac88bf404c9f2
1249 ++ (if platformArch platform == ArchSPARC
1250 then ["-mcpu=v9"]
1251 else [])
1252
1253 -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.
1254 ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)
1255 then ["-Wimplicit"]
1256 else [])
1257
1258 ++ (if hcc
1259 then gcc_extra_viac_flags ++ more_hcc_opts
1260 else [])
1261 ++ verbFlags
1262 ++ [ "-S" ]
1263 ++ cc_opt
1264 ++ [ "-include", ghcVersionH ]
1265 ++ framework_paths
1266 ++ include_paths
1267 ++ pkg_extra_cc_opts
1268 ))
1269
1270 return (RealPhase next_phase, output_fn)
1271
1272 -----------------------------------------------------------------------------
1273 -- Splitting phase
1274
1275 runPhase (RealPhase Splitter) input_fn dflags
1276 = do -- tmp_pfx is the prefix used for the split .s files
1277
1278 split_s_prefix <-
1279 liftIO $ newTempName dflags TFL_CurrentModule "split"
1280 let n_files_fn = split_s_prefix
1281
1282 liftIO $ SysTools.runSplit dflags
1283 [ SysTools.FileOption "" input_fn
1284 , SysTools.FileOption "" split_s_prefix
1285 , SysTools.FileOption "" n_files_fn
1286 ]
1287
1288 -- Save the number of split files for future references
1289 s <- liftIO $ readFile n_files_fn
1290 let n_files = read s :: Int
1291 dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }
1292
1293 setDynFlags dflags'
1294
1295 -- Remember to delete all these files
1296 liftIO $ addFilesToClean dflags' TFL_CurrentModule $
1297 [ split_s_prefix ++ "__" ++ show n ++ ".s"
1298 | n <- [1..n_files]]
1299
1300 return (RealPhase SplitAs,
1301 "**splitter**") -- we don't use the filename in SplitAs
1302
1303 -----------------------------------------------------------------------------
1304 -- As, SpitAs phase : Assembler
1305
1306 -- This is for calling the assembler on a regular assembly file (not split).
1307 runPhase (RealPhase (As with_cpp)) input_fn dflags
1308 = do
1309 -- LLVM from version 3.0 onwards doesn't support the OS X system
1310 -- assembler, so we use clang as the assembler instead. (#5636)
1311 let whichAsProg | hscTarget dflags == HscLlvm &&
1312 platformOS (targetPlatform dflags) == OSDarwin
1313 = return SysTools.runClang
1314 | otherwise = return SysTools.runAs
1315
1316 as_prog <- whichAsProg
1317 let cmdline_include_paths = includePaths dflags
1318 let pic_c_flags = picCCOpts dflags
1319
1320 next_phase <- maybeMergeForeign
1321 output_fn <- phaseOutputFilename next_phase
1322
1323 -- we create directories for the object file, because it
1324 -- might be a hierarchical module.
1325 liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
1326
1327 ccInfo <- liftIO $ getCompilerInfo dflags
1328 let global_includes = [ SysTools.Option ("-I" ++ p)
1329 | p <- includePathsGlobal cmdline_include_paths ]
1330 let local_includes = [ SysTools.Option ("-iquote" ++ p)
1331 | p <- includePathsQuote cmdline_include_paths ]
1332 let runAssembler inputFilename outputFilename
1333 = liftIO $ as_prog dflags
1334 (local_includes ++ global_includes
1335 -- See Note [-fPIC for assembler]
1336 ++ map SysTools.Option pic_c_flags
1337
1338 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1339 -- instruction so we have to make sure that the assembler accepts the
1340 -- instruction set. Note that the user can still override this
1341 -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1342 -- regardless of the ordering.
1343 --
1344 -- This is a temporary hack.
1345 ++ (if platformArch (targetPlatform dflags) == ArchSPARC
1346 then [SysTools.Option "-mcpu=v9"]
1347 else [])
1348 ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51]
1349 then [SysTools.Option "-Qunused-arguments"]
1350 else [])
1351 ++ [ SysTools.Option "-x"
1352 , if with_cpp
1353 then SysTools.Option "assembler-with-cpp"
1354 else SysTools.Option "assembler"
1355 , SysTools.Option "-c"
1356 , SysTools.FileOption "" inputFilename
1357 , SysTools.Option "-o"
1358 , SysTools.FileOption "" outputFilename
1359 ])
1360
1361 liftIO $ debugTraceMsg dflags 4 (text "Running the assembler")
1362 runAssembler input_fn output_fn
1363 return (RealPhase next_phase, output_fn)
1364
1365
1366 -- This is for calling the assembler on a split assembly file (so a collection
1367 -- of assembly files)
1368 runPhase (RealPhase SplitAs) _input_fn dflags
1369 = do
1370 -- we'll handle the stub_o file in this phase, so don't MergeForeign,
1371 -- just jump straight to StopLn afterwards.
1372 let next_phase = StopLn
1373 output_fn <- phaseOutputFilename next_phase
1374
1375 let base_o = dropExtension output_fn
1376 osuf = objectSuf dflags
1377 split_odir = base_o ++ "_" ++ osuf ++ "_split"
1378
1379 let pic_c_flags = picCCOpts dflags
1380
1381 -- this also creates the hierarchy
1382 liftIO $ createDirectoryIfMissing True split_odir
1383
1384 -- remove M_split/ *.o, because we're going to archive M_split/ *.o
1385 -- later and we don't want to pick up any old objects.
1386 fs <- liftIO $ getDirectoryContents split_odir
1387 liftIO $ mapM_ removeFile $
1388 map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
1389
1390 let (split_s_prefix, n) = case splitInfo dflags of
1391 Nothing -> panic "No split info"
1392 Just x -> x
1393
1394 let split_s n = split_s_prefix ++ "__" ++ show n <.> "s"
1395
1396 split_obj :: Int -> FilePath
1397 split_obj n = split_odir </>
1398 takeFileName base_o ++ "__" ++ show n <.> osuf
1399
1400 let assemble_file n
1401 = SysTools.runAs dflags (
1402
1403 -- We only support SparcV9 and better because V8 lacks an atomic CAS
1404 -- instruction so we have to make sure that the assembler accepts the
1405 -- instruction set. Note that the user can still override this
1406 -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1407 -- regardless of the ordering.
1408 --
1409 -- This is a temporary hack.
1410 (if platformArch (targetPlatform dflags) == ArchSPARC
1411 then [SysTools.Option "-mcpu=v9"]
1412 else []) ++
1413
1414 -- See Note [-fPIC for assembler]
1415 map SysTools.Option pic_c_flags ++
1416
1417 [ SysTools.Option "-c"
1418 , SysTools.Option "-o"
1419 , SysTools.FileOption "" (split_obj n)
1420 , SysTools.FileOption "" (split_s n)
1421 ])
1422
1423 liftIO $ mapM_ assemble_file [1..n]
1424
1425 -- Note [pipeline-split-init]
1426 -- If we have a stub file -- which will be part of foreign_os --
1427 -- it may contain constructor
1428 -- functions for initialisation of this module. We can't
1429 -- simply leave the stub as a separate object file, because it
1430 -- will never be linked in: nothing refers to it. We need to
1431 -- ensure that if we ever refer to the data in this module
1432 -- that needs initialisation, then we also pull in the
1433 -- initialisation routine.
1434 --
1435 -- To that end, we make a DANGEROUS ASSUMPTION here: the data
1436 -- that needs to be initialised is all in the FIRST split
1437 -- object. See Note [codegen-split-init].
1438 --
1439 -- We also merge in all the foreign objects since we're at it.
1440
1441 PipeState{foreign_os} <- getPipeState
1442 if null foreign_os
1443 then return ()
1444 else liftIO $ do
1445 tmp_split_1 <- newTempName dflags TFL_CurrentModule osuf
1446 let split_1 = split_obj 1
1447 copyFile split_1 tmp_split_1
1448 removeFile split_1
1449 joinObjectFiles dflags (tmp_split_1 : foreign_os) split_1
1450
1451 -- join them into a single .o file
1452 liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn
1453
1454 return (RealPhase next_phase, output_fn)
1455
1456 -----------------------------------------------------------------------------
1457 -- LlvmOpt phase
1458 runPhase (RealPhase LlvmOpt) input_fn dflags
1459 = do
1460 output_fn <- phaseOutputFilename LlvmLlc
1461
1462 liftIO $ SysTools.runLlvmOpt dflags
1463 ( optFlag
1464 ++ defaultOptions ++
1465 [ SysTools.FileOption "" input_fn
1466 , SysTools.Option "-o"
1467 , SysTools.FileOption "" output_fn]
1468 )
1469
1470 return (RealPhase LlvmLlc, output_fn)
1471 where
1472 -- we always (unless -optlo specified) run Opt since we rely on it to
1473 -- fix up some pretty big deficiencies in the code we generate
1474 llvmOpts = case optLevel dflags of
1475 0 -> "-mem2reg -globalopt"
1476 1 -> "-O1 -globalopt"
1477 _ -> "-O2"
1478
1479 -- don't specify anything if user has specified commands. We do this
1480 -- for opt but not llc since opt is very specifically for optimisation
1481 -- passes only, so if the user is passing us extra options we assume
1482 -- they know what they are doing and don't get in the way.
1483 optFlag = if null (getOpts dflags opt_lo)
1484 then map SysTools.Option $ words llvmOpts
1485 else []
1486
1487 defaultOptions = map SysTools.Option . concat . fmap words . fst
1488 $ unzip (llvmOptions dflags)
1489
1490 -----------------------------------------------------------------------------
1491 -- LlvmLlc phase
1492
1493 runPhase (RealPhase LlvmLlc) input_fn dflags
1494 = do
1495 next_phase <- if fastLlvmPipeline dflags
1496 then maybeMergeForeign
1497 -- hidden debugging flag '-dno-llvm-mangler' to skip mangling
1498 else case gopt Opt_NoLlvmMangler dflags of
1499 False -> return LlvmMangle
1500 True | gopt Opt_SplitObjs dflags -> return Splitter
1501 True -> return (As False)
1502
1503 output_fn <- phaseOutputFilename next_phase
1504
1505 liftIO $ SysTools.runLlvmLlc dflags
1506 ( optFlag
1507 ++ defaultOptions
1508 ++ [ SysTools.FileOption "" input_fn
1509 , SysTools.Option "-o"
1510 , SysTools.FileOption "" output_fn
1511 ]
1512 )
1513
1514 return (RealPhase next_phase, output_fn)
1515 where
1516 -- Note [Clamping of llc optimizations]
1517 --
1518 -- See #13724
1519 --
1520 -- we clamp the llc optimization between [1,2]. This is because passing -O0
1521 -- to llc 3.9 or llc 4.0, the naive register allocator can fail with
1522 --
1523 -- Error while trying to spill R1 from class GPR: Cannot scavenge register
1524 -- without an emergency spill slot!
1525 --
1526 -- Observed at least with target 'arm-unknown-linux-gnueabihf'.
1527 --
1528 --
1529 -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile
1530 -- rts/HeapStackCheck.cmm
1531 --
1532 -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s
1533 -- 0 llc 0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40
1534 -- 1 llc 0x0000000102ae69a6 SignalHandler(int) + 358
1535 -- 2 libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26
1536 -- 3 libsystem_c.dylib 0x00007fffc226498b __vfprintf + 17876
1537 -- 4 llc 0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699
1538 -- 5 llc 0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381
1539 -- 6 llc 0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457
1540 -- 7 llc 0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20
1541 -- 8 llc 0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134
1542 -- 9 llc 0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498
1543 -- 10 llc 0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67
1544 -- 11 llc 0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920
1545 -- 12 llc 0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133
1546 -- 13 llc 0x000000010195bf0b main + 491
1547 -- 14 libdyld.dylib 0x00007fffc21e5235 start + 1
1548 -- Stack dump:
1549 -- 0. Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s
1550 -- 1. Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'.
1551 -- 2. Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"'
1552 --
1553 -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa
1554 --
1555 llvmOpts = case optLevel dflags of
1556 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.
1557 1 -> "-O1"
1558 _ -> "-O2"
1559
1560 optFlag = if null (getOpts dflags opt_lc)
1561 then map SysTools.Option $ words llvmOpts
1562 else []
1563
1564 defaultOptions = map SysTools.Option . concat . fmap words . snd
1565 $ unzip (llvmOptions dflags)
1566
1567
1568 -----------------------------------------------------------------------------
1569 -- LlvmMangle phase
1570
1571 runPhase (RealPhase LlvmMangle) input_fn dflags
1572 = do
1573 let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As False
1574 output_fn <- phaseOutputFilename next_phase
1575 liftIO $ llvmFixupAsm dflags input_fn output_fn
1576 return (RealPhase next_phase, output_fn)
1577
1578 -----------------------------------------------------------------------------
1579 -- merge in stub objects
1580
1581 runPhase (RealPhase MergeForeign) input_fn dflags
1582 = do
1583 PipeState{foreign_os} <- getPipeState
1584 output_fn <- phaseOutputFilename StopLn
1585 liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
1586 if null foreign_os
1587 then panic "runPhase(MergeForeign): no foreign objects"
1588 else do
1589 liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn
1590 return (RealPhase StopLn, output_fn)
1591
1592 -- warning suppression
1593 runPhase (RealPhase other) _input_fn _dflags =
1594 panic ("runPhase: don't know how to run phase " ++ show other)
1595
1596 maybeMergeForeign :: CompPipeline Phase
1597 maybeMergeForeign
1598 = do
1599 PipeState{foreign_os} <- getPipeState
1600 if null foreign_os then return StopLn else return MergeForeign
1601
1602 getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation
1603 getLocation src_flavour mod_name = do
1604 dflags <- getDynFlags
1605
1606 PipeEnv{ src_basename=basename,
1607 src_suffix=suff } <- getPipeEnv
1608 PipeState { maybe_loc=maybe_loc} <- getPipeState
1609 case maybe_loc of
1610 -- Build a ModLocation to pass to hscMain.
1611 -- The source filename is rather irrelevant by now, but it's used
1612 -- by hscMain for messages. hscMain also needs
1613 -- the .hi and .o filenames. If we already have a ModLocation
1614 -- then simply update the extensions of the interface and object
1615 -- files to match the DynFlags, otherwise use the logic in Finder.
1616 Just l -> return $ l
1617 { ml_hs_file = Just $ basename <.> suff
1618 , ml_hi_file = ml_hi_file l -<.> hiSuf dflags
1619 , ml_obj_file = ml_obj_file l -<.> objectSuf dflags
1620 }
1621 _ -> do
1622 location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
1623
1624 -- Boot-ify it if necessary
1625 let location2 | HsBootFile <- src_flavour = addBootSuffixLocn location1
1626 | otherwise = location1
1627
1628
1629 -- Take -ohi into account if present
1630 -- This can't be done in mkHomeModuleLocation because
1631 -- it only applies to the module being compiles
1632 let ohi = outputHi dflags
1633 location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
1634 | otherwise = location2
1635
1636 -- Take -o into account if present
1637 -- Very like -ohi, but we must *only* do this if we aren't linking
1638 -- (If we're linking then the -o applies to the linked thing, not to
1639 -- the object file for one module.)
1640 -- Note the nasty duplication with the same computation in compileFile
1641 -- above
1642 let expl_o_file = outputFile dflags
1643 location4 | Just ofile <- expl_o_file
1644 , isNoLink (ghcLink dflags)
1645 = location3 { ml_obj_file = ofile }
1646 | otherwise = location3
1647 return location4
1648
1649 -----------------------------------------------------------------------------
1650 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1651
1652 getHCFilePackages :: FilePath -> IO [InstalledUnitId]
1653 getHCFilePackages filename =
1654 Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1655 l <- hGetLine h
1656 case l of
1657 '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1658 return (map stringToInstalledUnitId (words rest))
1659 _other ->
1660 return []
1661
1662 -----------------------------------------------------------------------------
1663 -- Static linking, of .o files
1664
1665 -- The list of packages passed to link is the list of packages on
1666 -- which this program depends, as discovered by the compilation
1667 -- manager. It is combined with the list of packages that the user
1668 -- specifies on the command line with -package flags.
1669 --
1670 -- In one-shot linking mode, we can't discover the package
1671 -- dependencies (because we haven't actually done any compilation or
1672 -- read any interface files), so the user must explicitly specify all
1673 -- the packages.
1674
1675 {-
1676 Note [-Xlinker -rpath vs -Wl,-rpath]
1677 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1678
1679 -Wl takes a comma-separated list of options which in the case of
1680 -Wl,-rpath -Wl,some,path,with,commas parses the path with commas
1681 as separate options.
1682 Buck, the build system, produces paths with commas in them.
1683
1684 -Xlinker doesn't have this disadvantage and as far as I can tell
1685 it is supported by both gcc and clang. Anecdotally nvcc supports
1686 -Xlinker, but not -Wl.
1687 -}
1688
1689 linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
1690 linkBinary = linkBinary' False
1691
1692 linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
1693 linkBinary' staticLink dflags o_files dep_packages = do
1694 let platform = targetPlatform dflags
1695 mySettings = settings dflags
1696 verbFlags = getVerbFlags dflags
1697 output_fn = exeFileName staticLink dflags
1698
1699 -- get the full list of packages to link with, by combining the
1700 -- explicit packages with the auto packages and all of their
1701 -- dependencies, and eliminating duplicates.
1702
1703 full_output_fn <- if isAbsolute output_fn
1704 then return output_fn
1705 else do d <- getCurrentDirectory
1706 return $ normalise (d </> output_fn)
1707 pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1708 let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1709 get_pkg_lib_path_opts l
1710 | osElfTarget (platformOS platform) &&
1711 dynLibLoader dflags == SystemDependent &&
1712 WayDyn `elem` ways dflags
1713 = let libpath = if gopt Opt_RelativeDynlibPaths dflags
1714 then "$ORIGIN" </>
1715 (l `makeRelativeTo` full_output_fn)
1716 else l
1717 -- See Note [-Xlinker -rpath vs -Wl,-rpath]
1718 rpath = if gopt Opt_RPath dflags
1719 then ["-Xlinker", "-rpath", "-Xlinker", libpath]
1720 else []
1721 -- Solaris 11's linker does not support -rpath-link option. It silently
1722 -- ignores it and then complains about next option which is -l<some
1723 -- dir> as being a directory and not expected object file, E.g
1724 -- ld: elf error: file
1725 -- /tmp/ghc-src/libraries/base/dist-install/build:
1726 -- elf_begin: I/O error: region read: Is a directory
1727 rpathlink = if (platformOS platform) == OSSolaris2
1728 then []
1729 else ["-Xlinker", "-rpath-link", "-Xlinker", l]
1730 in ["-L" ++ l] ++ rpathlink ++ rpath
1731 | osMachOTarget (platformOS platform) &&
1732 dynLibLoader dflags == SystemDependent &&
1733 WayDyn `elem` ways dflags &&
1734 gopt Opt_RPath dflags
1735 = let libpath = if gopt Opt_RelativeDynlibPaths dflags
1736 then "@loader_path" </>
1737 (l `makeRelativeTo` full_output_fn)
1738 else l
1739 in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]
1740 | otherwise = ["-L" ++ l]
1741
1742 let
1743 dead_strip
1744 | gopt Opt_WholeArchiveHsLibs dflags = []
1745 | otherwise = if osSubsectionsViaSymbols (platformOS platform)
1746 then ["-Wl,-dead_strip"]
1747 else []
1748 let lib_paths = libraryPaths dflags
1749 let lib_path_opts = map ("-L"++) lib_paths
1750
1751 extraLinkObj <- mkExtraObjToLinkIntoBinary dflags
1752 noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages
1753
1754 let
1755 (pre_hs_libs, post_hs_libs)
1756 | gopt Opt_WholeArchiveHsLibs dflags
1757 = if platformOS platform == OSDarwin
1758 then (["-Wl,-all_load"], [])
1759 -- OS X does not have a flag to turn off -all_load
1760 else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])
1761 | otherwise
1762 = ([],[])
1763
1764 pkg_link_opts <- do
1765 (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages
1766 return $ if staticLink
1767 then package_hs_libs -- If building an executable really means making a static
1768 -- library (e.g. iOS), then we only keep the -l options for
1769 -- HS packages, because libtool doesn't accept other options.
1770 -- In the case of iOS these need to be added by hand to the
1771 -- final link in Xcode.
1772 else other_flags ++ dead_strip
1773 ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs
1774 ++ extra_libs
1775 -- -Wl,-u,<sym> contained in other_flags
1776 -- needs to be put before -l<package>,
1777 -- otherwise Solaris linker fails linking
1778 -- a binary with unresolved symbols in RTS
1779 -- which are defined in base package
1780 -- the reason for this is a note in ld(1) about
1781 -- '-u' option: "The placement of this option
1782 -- on the command line is significant.
1783 -- This option must be placed before the library
1784 -- that defines the symbol."
1785
1786 -- frameworks
1787 pkg_framework_opts <- getPkgFrameworkOpts dflags platform dep_packages
1788 let framework_opts = getFrameworkOpts dflags platform
1789
1790 -- probably _stub.o files
1791 let extra_ld_inputs = ldInputs dflags
1792
1793 -- Here are some libs that need to be linked at the *end* of
1794 -- the command line, because they contain symbols that are referred to
1795 -- by the RTS. We can't therefore use the ordinary way opts for these.
1796 let debug_opts | WayDebug `elem` ways dflags = [
1797 #if defined(HAVE_LIBBFD)
1798 "-lbfd", "-liberty"
1799 #endif
1800 ]
1801 | otherwise = []
1802
1803 thread_opts | WayThreaded `elem` ways dflags = [
1804 #if NEED_PTHREAD_LIB
1805 "-lpthread"
1806 #endif
1807 ]
1808 | otherwise = []
1809
1810 rc_objs <- maybeCreateManifest dflags output_fn
1811
1812 let link = if staticLink
1813 then SysTools.runLibtool
1814 else SysTools.runLink
1815 link dflags (
1816 map SysTools.Option verbFlags
1817 ++ [ SysTools.Option "-o"
1818 , SysTools.FileOption "" output_fn
1819 ]
1820 ++ libmLinkOpts
1821 ++ map SysTools.Option (
1822 []
1823
1824 -- See Note [No PIE when linking]
1825 ++ picCCOpts dflags
1826
1827 -- Permit the linker to auto link _symbol to _imp_symbol.
1828 -- This lets us link against DLLs without needing an "import library".
1829 ++ (if platformOS platform == OSMinGW32
1830 then ["-Wl,--enable-auto-import"]
1831 else [])
1832
1833 -- '-no_compact_unwind'
1834 -- C++/Objective-C exceptions cannot use optimised
1835 -- stack unwinding code. The optimised form is the
1836 -- default in Xcode 4 on at least x86_64, and
1837 -- without this flag we're also seeing warnings
1838 -- like
1839 -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog
1840 -- on x86.
1841 ++ (if sLdSupportsCompactUnwind mySettings &&
1842 not staticLink &&
1843 (platformOS platform == OSDarwin) &&
1844 case platformArch platform of
1845 ArchX86 -> True
1846 ArchX86_64 -> True
1847 ArchARM {} -> True
1848 ArchARM64 -> True
1849 _ -> False
1850 then ["-Wl,-no_compact_unwind"]
1851 else [])
1852
1853 -- '-Wl,-read_only_relocs,suppress'
1854 -- ld gives loads of warnings like:
1855 -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure
1856 -- when linking any program. We're not sure
1857 -- whether this is something we ought to fix, but
1858 -- for now this flags silences them.
1859 ++ (if platformOS platform == OSDarwin &&
1860 platformArch platform == ArchX86 &&
1861 not staticLink
1862 then ["-Wl,-read_only_relocs,suppress"]
1863 else [])
1864
1865 ++ (if sLdIsGnuLd mySettings &&
1866 not (gopt Opt_WholeArchiveHsLibs dflags)
1867 then ["-Wl,--gc-sections"]
1868 else [])
1869
1870 ++ o_files
1871 ++ lib_path_opts)
1872 ++ extra_ld_inputs
1873 ++ map SysTools.Option (
1874 rc_objs
1875 ++ framework_opts
1876 ++ pkg_lib_path_opts
1877 ++ extraLinkObj:noteLinkObjs
1878 ++ pkg_link_opts
1879 ++ pkg_framework_opts
1880 ++ debug_opts
1881 ++ thread_opts
1882 ))
1883
1884 exeFileName :: Bool -> DynFlags -> FilePath
1885 exeFileName staticLink dflags
1886 | Just s <- outputFile dflags =
1887 case platformOS (targetPlatform dflags) of
1888 OSMinGW32 -> s <?.> "exe"
1889 _ -> if staticLink
1890 then s <?.> "a"
1891 else s
1892 | otherwise =
1893 if platformOS (targetPlatform dflags) == OSMinGW32
1894 then "main.exe"
1895 else if staticLink
1896 then "liba.a"
1897 else "a.out"
1898 where s <?.> ext | null (takeExtension s) = s <.> ext
1899 | otherwise = s
1900
1901 maybeCreateManifest
1902 :: DynFlags
1903 -> FilePath -- filename of executable
1904 -> IO [FilePath] -- extra objects to embed, maybe
1905 maybeCreateManifest dflags exe_filename
1906 | platformOS (targetPlatform dflags) == OSMinGW32 &&
1907 gopt Opt_GenManifest dflags
1908 = do let manifest_filename = exe_filename <.> "manifest"
1909
1910 writeFile manifest_filename $
1911 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
1912 " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
1913 " <assemblyIdentity version=\"1.0.0.0\"\n"++
1914 " processorArchitecture=\"X86\"\n"++
1915 " name=\"" ++ dropExtension exe_filename ++ "\"\n"++
1916 " type=\"win32\"/>\n\n"++
1917 " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
1918 " <security>\n"++
1919 " <requestedPrivileges>\n"++
1920 " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
1921 " </requestedPrivileges>\n"++
1922 " </security>\n"++
1923 " </trustInfo>\n"++
1924 "</assembly>\n"
1925
1926 -- Windows will find the manifest file if it is named
1927 -- foo.exe.manifest. However, for extra robustness, and so that
1928 -- we can move the binary around, we can embed the manifest in
1929 -- the binary itself using windres:
1930 if not (gopt Opt_EmbedManifest dflags) then return [] else do
1931
1932 rc_filename <- newTempName dflags TFL_CurrentModule "rc"
1933 rc_obj_filename <-
1934 newTempName dflags TFL_GhcSession (objectSuf dflags)
1935
1936 writeFile rc_filename $
1937 "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
1938 -- magic numbers :-)
1939 -- show is a bit hackish above, but we need to escape the
1940 -- backslashes in the path.
1941
1942 runWindres dflags $ map SysTools.Option $
1943 ["--input="++rc_filename,
1944 "--output="++rc_obj_filename,
1945 "--output-format=coff"]
1946 -- no FileOptions here: windres doesn't like seeing
1947 -- backslashes, apparently
1948
1949 removeFile manifest_filename
1950
1951 return [rc_obj_filename]
1952 | otherwise = return []
1953
1954
1955 linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
1956 linkDynLibCheck dflags o_files dep_packages
1957 = do
1958 when (haveRtsOptsFlags dflags) $ do
1959 putLogMsg dflags NoReason SevInfo noSrcSpan
1960 (defaultUserStyle dflags)
1961 (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
1962 text " Call hs_init_ghc() from your main() function to set these options.")
1963
1964 linkDynLib dflags o_files dep_packages
1965
1966 -- | Linking a static lib will not really link anything. It will merely produce
1967 -- a static archive of all dependent static libraries. The resulting library
1968 -- will still need to be linked with any remaining link flags.
1969 linkStaticLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
1970 linkStaticLib dflags o_files dep_packages = do
1971 let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
1972 modules = o_files ++ extra_ld_inputs
1973 output_fn = exeFileName True dflags
1974
1975 full_output_fn <- if isAbsolute output_fn
1976 then return output_fn
1977 else do d <- getCurrentDirectory
1978 return $ normalise (d </> output_fn)
1979 output_exists <- doesFileExist full_output_fn
1980 (when output_exists) $ removeFile full_output_fn
1981
1982 pkg_cfgs <- getPreloadPackagesAnd dflags dep_packages
1983 archives <- concat <$> mapM (collectArchives dflags) pkg_cfgs
1984
1985 ar <- foldl mappend
1986 <$> (Archive <$> mapM loadObj modules)
1987 <*> mapM loadAr archives
1988
1989 if sLdIsGnuLd (settings dflags)
1990 then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar
1991 else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar
1992
1993 -- run ranlib over the archive. write*Ar does *not* create the symbol index.
1994 runRanlib dflags [SysTools.FileOption "" output_fn]
1995
1996 -- -----------------------------------------------------------------------------
1997 -- Running CPP
1998
1999 doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
2000 doCpp dflags raw input_fn output_fn = do
2001 let hscpp_opts = picPOpts dflags
2002 let cmdline_include_paths = includePaths dflags
2003
2004 pkg_include_dirs <- getPackageIncludePath dflags []
2005 let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
2006 (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
2007 let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
2008 (includePathsQuote cmdline_include_paths)
2009 let include_paths = include_paths_quote ++ include_paths_global
2010
2011 let verbFlags = getVerbFlags dflags
2012
2013 let cpp_prog args | raw = SysTools.runCpp dflags args
2014 | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
2015
2016 let target_defs =
2017 [ "-D" ++ HOST_OS ++ "_BUILD_OS",
2018 "-D" ++ HOST_ARCH ++ "_BUILD_ARCH",
2019 "-D" ++ TARGET_OS ++ "_HOST_OS",
2020 "-D" ++ TARGET_ARCH ++ "_HOST_ARCH" ]
2021 -- remember, in code we *compile*, the HOST is the same our TARGET,
2022 -- and BUILD is the same as our HOST.
2023
2024 let sse_defs =
2025 [ "-D__SSE__" | isSseEnabled dflags ] ++
2026 [ "-D__SSE2__" | isSse2Enabled dflags ] ++
2027 [ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
2028
2029 let avx_defs =
2030 [ "-D__AVX__" | isAvxEnabled dflags ] ++
2031 [ "-D__AVX2__" | isAvx2Enabled dflags ] ++
2032 [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
2033 [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
2034 [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
2035 [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
2036
2037 backend_defs <- getBackendDefs dflags
2038
2039 let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
2040 -- Default CPP defines in Haskell source
2041 ghcVersionH <- getGhcVersionPathName dflags
2042 let hsSourceCppOpts = [ "-include", ghcVersionH ]
2043
2044 -- MIN_VERSION macros
2045 let uids = explicitPackages (pkgState dflags)
2046 pkgs = catMaybes (map (lookupPackage dflags) uids)
2047 mb_macro_include <-
2048 if not (null pkgs) && gopt Opt_VersionMacros dflags
2049 then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
2050 writeFile macro_stub (generatePackageVersionMacros pkgs)
2051 -- Include version macros for every *exposed* package.
2052 -- Without -hide-all-packages and with a package database
2053 -- size of 1000 packages, it takes cpp an estimated 2
2054 -- milliseconds to process this file. See Trac #10970
2055 -- comment 8.
2056 return [SysTools.FileOption "-include" macro_stub]
2057 else return []
2058
2059 cpp_prog ( map SysTools.Option verbFlags
2060 ++ map SysTools.Option include_paths
2061 ++ map SysTools.Option hsSourceCppOpts
2062 ++ map SysTools.Option target_defs
2063 ++ map SysTools.Option backend_defs
2064 ++ map SysTools.Option th_defs
2065 ++ map SysTools.Option hscpp_opts
2066 ++ map SysTools.Option sse_defs
2067 ++ map SysTools.Option avx_defs
2068 ++ mb_macro_include
2069 -- Set the language mode to assembler-with-cpp when preprocessing. This
2070 -- alleviates some of the C99 macro rules relating to whitespace and the hash
2071 -- operator, which we tend to abuse. Clang in particular is not very happy
2072 -- about this.
2073 ++ [ SysTools.Option "-x"
2074 , SysTools.Option "assembler-with-cpp"
2075 , SysTools.Option input_fn
2076 -- We hackily use Option instead of FileOption here, so that the file
2077 -- name is not back-slashed on Windows. cpp is capable of
2078 -- dealing with / in filenames, so it works fine. Furthermore
2079 -- if we put in backslashes, cpp outputs #line directives
2080 -- with *double* backslashes. And that in turn means that
2081 -- our error messages get double backslashes in them.
2082 -- In due course we should arrange that the lexer deals
2083 -- with these \\ escapes properly.
2084 , SysTools.Option "-o"
2085 , SysTools.FileOption "" output_fn
2086 ])
2087
2088 getBackendDefs :: DynFlags -> IO [String]
2089 getBackendDefs dflags | hscTarget dflags == HscLlvm = do
2090 llvmVer <- figureLlvmVersion dflags
2091 return $ case llvmVer of
2092 Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]
2093 _ -> []
2094 where
2095 format (major, minor)
2096 | minor >= 100 = error "getBackendDefs: Unsupported minor version"
2097 | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
2098
2099 getBackendDefs _ =
2100 return []
2101
2102 -- ---------------------------------------------------------------------------
2103 -- Macros (cribbed from Cabal)
2104
2105 generatePackageVersionMacros :: [PackageConfig] -> String
2106 generatePackageVersionMacros pkgs = concat
2107 -- Do not add any C-style comments. See Trac #3389.
2108 [ generateMacros "" pkgname version
2109 | pkg <- pkgs
2110 , let version = packageVersion pkg
2111 pkgname = map fixchar (packageNameString pkg)
2112 ]
2113
2114 fixchar :: Char -> Char
2115 fixchar '-' = '_'
2116 fixchar c = c
2117
2118 generateMacros :: String -> String -> Version -> String
2119 generateMacros prefix name version =
2120 concat
2121 ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
2122 ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
2123 ," (major1) < ",major1," || \\\n"
2124 ," (major1) == ",major1," && (major2) < ",major2," || \\\n"
2125 ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
2126 ,"\n\n"
2127 ]
2128 where
2129 (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
2130
2131 -- ---------------------------------------------------------------------------
2132 -- join object files into a single relocatable object file, using ld -r
2133
2134 joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
2135 joinObjectFiles dflags o_files output_fn = do
2136 let mySettings = settings dflags
2137 ldIsGnuLd = sLdIsGnuLd mySettings
2138 osInfo = platformOS (targetPlatform dflags)
2139 ld_r args cc = SysTools.runLink dflags ([
2140 SysTools.Option "-nostdlib",
2141 SysTools.Option "-Wl,-r"
2142 ]
2143 -- See Note [No PIE while linking] in SysTools
2144 ++ (if sGccSupportsNoPie mySettings
2145 then [SysTools.Option "-no-pie"]
2146 else [])
2147
2148 ++ (if any (cc ==) [Clang, AppleClang, AppleClang51]
2149 then []
2150 else [SysTools.Option "-nodefaultlibs"])
2151 ++ (if osInfo == OSFreeBSD
2152 then [SysTools.Option "-L/usr/lib"]
2153 else [])
2154 -- gcc on sparc sets -Wl,--relax implicitly, but
2155 -- -r and --relax are incompatible for ld, so
2156 -- disable --relax explicitly.
2157 ++ (if platformArch (targetPlatform dflags)
2158 `elem` [ArchSPARC, ArchSPARC64]
2159 && ldIsGnuLd
2160 then [SysTools.Option "-Wl,-no-relax"]
2161 else [])
2162 ++ map SysTools.Option ld_build_id
2163 ++ [ SysTools.Option "-o",
2164 SysTools.FileOption "" output_fn ]
2165 ++ args)
2166
2167 -- suppress the generation of the .note.gnu.build-id section,
2168 -- which we don't need and sometimes causes ld to emit a
2169 -- warning:
2170 ld_build_id | sLdSupportsBuildId mySettings = ["-Wl,--build-id=none"]
2171 | otherwise = []
2172
2173 ccInfo <- getCompilerInfo dflags
2174 if ldIsGnuLd
2175 then do
2176 script <- newTempName dflags TFL_CurrentModule "ldscript"
2177 cwd <- getCurrentDirectory
2178 let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files
2179 writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"
2180 ld_r [SysTools.FileOption "" script] ccInfo
2181 else if sLdSupportsFilelist mySettings
2182 then do
2183 filelist <- newTempName dflags TFL_CurrentModule "filelist"
2184 writeFile filelist $ unlines o_files
2185 ld_r [SysTools.Option "-Wl,-filelist",
2186 SysTools.FileOption "-Wl," filelist] ccInfo
2187 else do
2188 ld_r (map (SysTools.FileOption "") o_files) ccInfo
2189
2190 -- -----------------------------------------------------------------------------
2191 -- Misc.
2192
2193 writeInterfaceOnlyMode :: DynFlags -> Bool
2194 writeInterfaceOnlyMode dflags =
2195 gopt Opt_WriteInterface dflags &&
2196 HscNothing == hscTarget dflags
2197
2198 -- | What phase to run after one of the backend code generators has run
2199 hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase
2200 hscPostBackendPhase _ HsBootFile _ = StopLn
2201 hscPostBackendPhase _ HsigFile _ = StopLn
2202 hscPostBackendPhase dflags _ hsc_lang =
2203 case hsc_lang of
2204 HscC -> HCc
2205 HscAsm | gopt Opt_SplitObjs dflags -> Splitter
2206 | otherwise -> As False
2207 HscLlvm -> LlvmOpt
2208 HscNothing -> StopLn
2209 HscInterpreted -> StopLn
2210
2211 touchObjectFile :: DynFlags -> FilePath -> IO ()
2212 touchObjectFile dflags path = do
2213 createDirectoryIfMissing True $ takeDirectory path
2214 SysTools.touch dflags "Touching object file" path
2215
2216 -- | Find out path to @ghcversion.h@ file
2217 getGhcVersionPathName :: DynFlags -> IO FilePath
2218 getGhcVersionPathName dflags = do
2219 candidates <- case ghcVersionFile dflags of
2220 Just path -> return [path]
2221 Nothing -> (map (</> "ghcversion.h")) <$>
2222 (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId])
2223
2224 found <- filterM doesFileExist candidates
2225 case found of
2226 [] -> throwGhcExceptionIO (InstallationError
2227 ("ghcversion.h missing; tried: "
2228 ++ intercalate ", " candidates))
2229 (x:_) -> return x
2230
2231 -- Note [-fPIC for assembler]
2232 -- When compiling .c source file GHC's driver pipeline basically
2233 -- does the following two things:
2234 -- 1. ${CC} -S 'PIC_CFLAGS' source.c
2235 -- 2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S
2236 --
2237 -- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler?
2238 -- Because on some architectures (at least sparc32) assembler also chooses
2239 -- the relocation type!
2240 -- Consider the following C module:
2241 --
2242 -- /* pic-sample.c */
2243 -- int v;
2244 -- void set_v (int n) { v = n; }
2245 -- int get_v (void) { return v; }
2246 --
2247 -- $ gcc -S -fPIC pic-sample.c
2248 -- $ gcc -c pic-sample.s -o pic-sample.no-pic.o # incorrect binary
2249 -- $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o # correct binary
2250 --
2251 -- $ objdump -r -d pic-sample.pic.o > pic-sample.pic.o.od
2252 -- $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od
2253 -- $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od
2254 --
2255 -- Most of architectures won't show any difference in this test, but on sparc32
2256 -- the following assembly snippet:
2257 --
2258 -- sethi %hi(_GLOBAL_OFFSET_TABLE_-8), %l7
2259 --
2260 -- generates two kinds or relocations, only 'R_SPARC_PC22' is correct:
2261 --
2262 -- 3c: 2f 00 00 00 sethi %hi(0), %l7
2263 -- - 3c: R_SPARC_PC22 _GLOBAL_OFFSET_TABLE_-0x8
2264 -- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8
2265
2266 {- Note [Don't normalise input filenames]
2267
2268 Summary
2269 We used to normalise input filenames when starting the unlit phase. This
2270 broke hpc in `--make` mode with imported literate modules (#2991).
2271
2272 Introduction
2273 1) --main
2274 When compiling a module with --main, GHC scans its imports to find out which
2275 other modules it needs to compile too. It turns out that there is a small
2276 difference between saying `ghc --make A.hs`, when `A` imports `B`, and
2277 specifying both modules on the command line with `ghc --make A.hs B.hs`. In
2278 the former case, the filename for B is inferred to be './B.hs' instead of
2279 'B.hs'.
2280
2281 2) unlit
2282 When GHC compiles a literate haskell file, the source code first needs to go
2283 through unlit, which turns it into normal Haskell source code. At the start
2284 of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the
2285 option `-h` and the name of the original file. We used to normalise this
2286 filename using System.FilePath.normalise, which among other things removes
2287 an initial './'. unlit then uses that filename in #line directives that it
2288 inserts in the transformed source code.
2289
2290 3) SrcSpan
2291 A SrcSpan represents a portion of a source code file. It has fields
2292 linenumber, start column, end column, and also a reference to the file it
2293 originated from. The SrcSpans for a literate haskell file refer to the
2294 filename that was passed to unlit -h.
2295
2296 4) -fhpc
2297 At some point during compilation with -fhpc, in the function
2298 `deSugar.Coverage.isGoodTickSrcSpan`, we compare the filename that a
2299 `SrcSpan` refers to with the name of the file we are currently compiling.
2300 For some reason I don't yet understand, they can sometimes legitimally be
2301 different, and then hpc ignores that SrcSpan.
2302
2303 Problem
2304 When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate
2305 module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the
2306 start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2).
2307 Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are
2308 still compiling `./B.lhs`. Hpc thinks these two filenames are different (4),
2309 doesn't include ticks for B, and we have unhappy customers (#2991).
2310
2311 Solution
2312 Do not normalise `input_fn` when starting the unlit phase.
2313
2314 Alternative solution
2315 Another option would be to not compare the two filenames on equality, but to
2316 use System.FilePath.equalFilePath. That function first normalises its
2317 arguments. The problem is that by the time we need to do the comparison, the
2318 filenames have been turned into FastStrings, probably for performance
2319 reasons, so System.FilePath.equalFilePath can not be used directly.
2320
2321 Archeology
2322 The call to `normalise` was added in a commit called "Fix slash
2323 direction on Windows with the new filePath code" (c9b6b5e8). The problem
2324 that commit was addressing has since been solved in a different manner, in a
2325 commit called "Fix the filename passed to unlit" (1eedbc6b). So the
2326 `normalise` is no longer necessary.
2327 -}