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