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