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