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