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