never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE BangPatterns #-}
3
4 {-# LANGUAGE NamedFieldPuns #-}
5 {-# LANGUAGE NondecreasingIndentation #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE LambdaCase #-}
8 {-# LANGUAGE ConstraintKinds #-}
9 {-# LANGUAGE FlexibleContexts #-}
10
11 -----------------------------------------------------------------------------
12 --
13 -- GHC Driver
14 --
15 -- (c) The University of Glasgow 2005
16 --
17 -----------------------------------------------------------------------------
18
19 module GHC.Driver.Pipeline (
20 -- * Run a series of compilation steps in a pipeline, for a
21 -- collection of source files.
22 oneShot, compileFile,
23
24 -- * Interfaces for the compilation manager (interpreted/batch-mode)
25 preprocess,
26 compileOne, compileOne',
27 compileForeign, compileEmptyStub,
28
29 -- * Linking
30 link, linkingNeeded, checkLinkInfo,
31
32 -- * PipeEnv
33 PipeEnv(..), mkPipeEnv, phaseOutputFilenameNew,
34
35 -- * Running individual phases
36 TPhase(..), runPhase,
37 hscPostBackendPhase,
38
39 -- * Constructing Pipelines
40 TPipelineClass, MonadUse(..),
41
42 preprocessPipeline, fullPipeline, hscPipeline, hscBackendPipeline, hscPostBackendPipeline,
43 hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline,
44 llvmPipeline, llvmLlcPipeline, llvmManglePipeline, pipelineStart,
45
46 -- * Default method of running a pipeline
47 runPipeline
48 ) where
49
50
51 #include "ghcplatform.h"
52 import GHC.Prelude
53
54 import GHC.Platform
55
56 import GHC.Utils.Monad ( MonadIO(liftIO), mapMaybeM )
57
58 import GHC.Driver.Main
59 import GHC.Driver.Env hiding ( Hsc )
60 import GHC.Driver.Errors
61 import GHC.Driver.Errors.Types
62 import GHC.Driver.Pipeline.Monad
63 import GHC.Driver.Config.Diagnostic
64 import GHC.Driver.Phases
65 import GHC.Driver.Pipeline.Execute
66 import GHC.Driver.Pipeline.Phases
67 import GHC.Driver.Session
68 import GHC.Driver.Backend
69 import GHC.Driver.Ppr
70 import GHC.Driver.Hooks
71
72 import GHC.Platform.Ways
73
74 import GHC.SysTools
75 import GHC.Utils.TmpFs
76
77 import GHC.Linker.ExtraObj
78 import GHC.Linker.Static
79 import GHC.Linker.Types
80
81 import GHC.Utils.Outputable
82 import GHC.Utils.Error
83 import GHC.Utils.Panic
84 import GHC.Utils.Misc
85 import GHC.Utils.Exception as Exception
86 import GHC.Utils.Logger
87
88 import qualified GHC.LanguageExtensions as LangExt
89
90 import GHC.Data.FastString ( mkFastString )
91 import GHC.Data.StringBuffer ( hPutStringBuffer )
92 import GHC.Data.Maybe ( expectJust )
93
94 import GHC.Iface.Make ( mkFullIface )
95 import GHC.Runtime.Loader ( initializePlugins )
96
97
98 import GHC.Types.Basic ( SuccessFlag(..), ForeignSrcLang(..) )
99 import GHC.Types.Error ( singleMessage, getMessages )
100 import GHC.Types.Target
101 import GHC.Types.SrcLoc
102 import GHC.Types.SourceFile
103 import GHC.Types.SourceError
104
105 import GHC.Unit
106 import GHC.Unit.Env
107 --import GHC.Unit.Finder
108 --import GHC.Unit.State
109 import GHC.Unit.Module.ModSummary
110 import GHC.Unit.Module.ModIface
111 import GHC.Unit.Module.Graph (needsTemplateHaskellOrQQ)
112 import GHC.Unit.Module.Deps
113 import GHC.Unit.Home.ModInfo
114
115 import System.Directory
116 import System.FilePath
117 import System.IO
118 import Control.Monad
119 import qualified Control.Monad.Catch as MC (handle)
120 import Data.Maybe
121 import Data.Either ( partitionEithers )
122 import qualified Data.Set as Set
123
124 import Data.Time ( getCurrentTime )
125
126 -- Simpler type synonym for actions in the pipeline monad
127 type P m = TPipelineClass TPhase m
128
129 -- ---------------------------------------------------------------------------
130 -- Pre-process
131
132 -- | Just preprocess a file, put the result in a temp. file (used by the
133 -- compilation manager during the summary phase).
134 --
135 -- We return the augmented DynFlags, because they contain the result
136 -- of slurping in the OPTIONS pragmas
137
138 preprocess :: HscEnv
139 -> FilePath -- ^ input filename
140 -> Maybe InputFileBuffer
141 -- ^ optional buffer to use instead of reading the input file
142 -> Maybe Phase -- ^ starting phase
143 -> IO (Either DriverMessages (DynFlags, FilePath))
144 preprocess hsc_env input_fn mb_input_buf mb_phase =
145 handleSourceError (\err -> return $ Left $ to_driver_messages $ srcErrorMessages err) $
146 MC.handle handler $
147 fmap Right $ do
148 massertPpr (isJust mb_phase || isHaskellSrcFilename input_fn) (text input_fn)
149 input_fn_final <- mkInputFn
150 let preprocess_pipeline = preprocessPipeline pipe_env (setDumpPrefix pipe_env hsc_env) input_fn_final
151 runPipeline (hsc_hooks hsc_env) preprocess_pipeline
152
153 where
154 srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1
155 handler (ProgramError msg) =
156 return $ Left $ singleMessage $
157 mkPlainErrorMsgEnvelope srcspan $
158 DriverUnknownMessage $ mkPlainError noHints $ text msg
159 handler ex = throwGhcExceptionIO ex
160
161 to_driver_messages :: Messages GhcMessage -> Messages DriverMessage
162 to_driver_messages msgs = case traverse to_driver_message msgs of
163 Nothing -> pprPanic "non-driver message in preprocess"
164 (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs))
165 Just msgs' -> msgs'
166
167 to_driver_message = \case
168 GhcDriverMessage msg
169 -> Just msg
170 GhcPsMessage (PsHeaderMessage msg)
171 -> Just (DriverPsHeaderMessage (PsHeaderMessage msg))
172 _ -> Nothing
173
174 pipe_env = mkPipeEnv StopPreprocess input_fn (Temporary TFL_GhcSession)
175 mkInputFn =
176 case mb_input_buf of
177 Just input_buf -> do
178 fn <- newTempName (hsc_logger hsc_env)
179 (hsc_tmpfs hsc_env)
180 (tmpDir (hsc_dflags hsc_env))
181 TFL_CurrentModule
182 ("buf_" ++ src_suffix pipe_env)
183 hdl <- openBinaryFile fn WriteMode
184 -- Add a LINE pragma so reported source locations will
185 -- mention the real input file, not this temp file.
186 hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}"
187 hPutStringBuffer hdl input_buf
188 hClose hdl
189 return fn
190 Nothing -> return input_fn
191
192 -- ---------------------------------------------------------------------------
193
194 -- | Compile
195 --
196 -- Compile a single module, under the control of the compilation manager.
197 --
198 -- This is the interface between the compilation manager and the
199 -- compiler proper (hsc), where we deal with tedious details like
200 -- reading the OPTIONS pragma from the source file, converting the
201 -- C or assembly that GHC produces into an object file, and compiling
202 -- FFI stub files.
203 --
204 -- NB. No old interface can also mean that the source has changed.
205
206
207 compileOne :: HscEnv
208 -> ModSummary -- ^ summary for module being compiled
209 -> Int -- ^ module N ...
210 -> Int -- ^ ... of M
211 -> Maybe ModIface -- ^ old interface, if we have one
212 -> Maybe Linkable -- ^ old linkable, if we have one
213 -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful
214
215 compileOne = compileOne' (Just batchMsg)
216
217 compileOne' :: Maybe Messager
218 -> HscEnv
219 -> ModSummary -- ^ summary for module being compiled
220 -> Int -- ^ module N ...
221 -> Int -- ^ ... of M
222 -> Maybe ModIface -- ^ old interface, if we have one
223 -> Maybe Linkable -- ^ old linkable, if we have one
224 -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful
225
226 compileOne' mHscMessage
227 hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable
228 = do
229
230 debugTraceMsg logger 2 (text "compile: input file" <+> text input_fnpp)
231
232 let flags = hsc_dflags hsc_env0
233 in do unless (gopt Opt_KeepHiFiles flags) $
234 addFilesToClean tmpfs TFL_CurrentModule $
235 [ml_hi_file $ ms_location summary]
236 unless (gopt Opt_KeepOFiles flags) $
237 addFilesToClean tmpfs TFL_GhcSession $
238 [ml_obj_file $ ms_location summary]
239
240 plugin_hsc_env <- initializePlugins hsc_env (Just (ms_mnwib summary))
241 let pipe_env = mkPipeEnv NoStop input_fn pipelineOutput
242 status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary
243 mb_old_iface mb_old_linkable (mod_index, nmods)
244 let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status)
245 (iface, linkable) <- runPipeline (hsc_hooks hsc_env) pipeline
246 -- See Note [ModDetails and --make mode]
247 details <- initModDetails plugin_hsc_env upd_summary iface
248 return $! HomeModInfo iface details linkable
249
250 where lcl_dflags = ms_hspp_opts summary
251 location = ms_location summary
252 input_fn = expectJust "compile:hs" (ml_hs_file location)
253 input_fnpp = ms_hspp_file summary
254 mod_graph = hsc_mod_graph hsc_env0
255 needsLinker = needsTemplateHaskellOrQQ mod_graph
256 isDynWay = hasWay (ways lcl_dflags) WayDyn
257 isProfWay = hasWay (ways lcl_dflags) WayProf
258 internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)
259
260 pipelineOutput = case bcknd of
261 Interpreter -> NoOutputFile
262 NoBackend -> NoOutputFile
263 _ -> Persistent
264
265 logger = hsc_logger hsc_env0
266 tmpfs = hsc_tmpfs hsc_env0
267
268 -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
269 -- the linker can correctly load the object files. This isn't necessary
270 -- when using -fexternal-interpreter.
271 dflags1 = if hostIsDynamic && internalInterpreter &&
272 not isDynWay && not isProfWay && needsLinker
273 then gopt_set lcl_dflags Opt_BuildDynamicToo
274 else lcl_dflags
275
276 -- #16331 - when no "internal interpreter" is available but we
277 -- need to process some TemplateHaskell or QuasiQuotes, we automatically
278 -- turn on -fexternal-interpreter.
279 dflags2 = if not internalInterpreter && needsLinker
280 then gopt_set dflags1 Opt_ExternalInterpreter
281 else dflags1
282
283 basename = dropExtension input_fn
284
285 -- We add the directory in which the .hs files resides) to the import
286 -- path. This is needed when we try to compile the .hc file later, if it
287 -- imports a _stub.h file that we created here.
288 current_dir = takeDirectory basename
289 old_paths = includePaths dflags2
290 loadAsByteCode
291 | Just Target { targetAllowObjCode = obj } <- findTarget summary (hsc_targets hsc_env0)
292 , not obj
293 = True
294 | otherwise = False
295 -- Figure out which backend we're using
296 (bcknd, dflags3)
297 -- #8042: When module was loaded with `*` prefix in ghci, but DynFlags
298 -- suggest to generate object code (which may happen in case -fobject-code
299 -- was set), force it to generate byte-code. This is NOT transitive and
300 -- only applies to direct targets.
301 | loadAsByteCode
302 = (Interpreter, gopt_set (dflags2 { backend = Interpreter }) Opt_ForceRecomp)
303 | otherwise
304 = (backend dflags, dflags2)
305 dflags = dflags3 { includePaths = addImplicitQuoteInclude old_paths [current_dir] }
306 upd_summary = summary { ms_hspp_opts = dflags }
307 hsc_env = hscSetFlags dflags hsc_env0
308
309 -- ---------------------------------------------------------------------------
310 -- Link
311 --
312 -- Note [Dynamic linking on macOS]
313 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
314 --
315 -- Since macOS Sierra (10.14), the dynamic system linker enforces
316 -- a limit on the Load Commands. Specifically the Load Command Size
317 -- Limit is at 32K (32768). The Load Commands contain the install
318 -- name, dependencies, runpaths, and a few other commands. We however
319 -- only have control over the install name, dependencies and runpaths.
320 --
321 -- The install name is the name by which this library will be
322 -- referenced. This is such that we do not need to bake in the full
323 -- absolute location of the library, and can move the library around.
324 --
325 -- The dependency commands contain the install names from of referenced
326 -- libraries. Thus if a libraries install name is @rpath/libHS...dylib,
327 -- that will end up as the dependency.
328 --
329 -- Finally we have the runpaths, which informs the linker about the
330 -- directories to search for the referenced dependencies.
331 --
332 -- The system linker can do recursive linking, however using only the
333 -- direct dependencies conflicts with ghc's ability to inline across
334 -- packages, and as such would end up with unresolved symbols.
335 --
336 -- Thus we will pass the full dependency closure to the linker, and then
337 -- ask the linker to remove any unused dynamic libraries (-dead_strip_dylibs).
338 --
339 -- We still need to add the relevant runpaths, for the dynamic linker to
340 -- lookup the referenced libraries though. The linker (ld64) does not
341 -- have any option to dead strip runpaths; which makes sense as runpaths
342 -- can be used for dependencies of dependencies as well.
343 --
344 -- The solution we then take in GHC is to not pass any runpaths to the
345 -- linker at link time, but inject them after the linking. For this to
346 -- work we'll need to ask the linker to create enough space in the header
347 -- to add more runpaths after the linking (-headerpad 8000).
348 --
349 -- After the library has been linked by $LD (usually ld64), we will use
350 -- otool to inspect the libraries left over after dead stripping, compute
351 -- the relevant runpaths, and inject them into the linked product using
352 -- the install_name_tool command.
353 --
354 -- This strategy should produce the smallest possible set of load commands
355 -- while still retaining some form of relocatability via runpaths.
356 --
357 -- The only way I can see to reduce the load command size further would be
358 -- by shortening the library names, or start putting libraries into the same
359 -- folders, such that one runpath would be sufficient for multiple/all
360 -- libraries.
361 link :: GhcLink -- ^ interactive or batch
362 -> Logger -- ^ Logger
363 -> TmpFs
364 -> Hooks
365 -> DynFlags -- ^ dynamic flags
366 -> UnitEnv -- ^ unit environment
367 -> Bool -- ^ attempt linking in batch mode?
368 -> HomePackageTable -- ^ what to link
369 -> IO SuccessFlag
370
371 -- For the moment, in the batch linker, we don't bother to tell doLink
372 -- which packages to link -- it just tries all that are available.
373 -- batch_attempt_linking should only be *looked at* in batch mode. It
374 -- should only be True if the upsweep was successful and someone
375 -- exports main, i.e., we have good reason to believe that linking
376 -- will succeed.
377
378 link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking hpt =
379 case linkHook hooks of
380 Nothing -> case ghcLink of
381 NoLink -> return Succeeded
382 LinkBinary -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt
383 LinkStaticLib -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt
384 LinkDynLib -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt
385 LinkInMemory
386 | platformMisc_ghcWithInterpreter $ platformMisc dflags
387 -> -- Not Linking...(demand linker will do the job)
388 return Succeeded
389 | otherwise
390 -> panicBadLink LinkInMemory
391 Just h -> h ghcLink dflags batch_attempt_linking hpt
392
393
394 panicBadLink :: GhcLink -> a
395 panicBadLink other = panic ("link: GHC not built to link this way: " ++
396 show other)
397
398 link' :: Logger
399 -> TmpFs
400 -> DynFlags -- ^ dynamic flags
401 -> UnitEnv -- ^ unit environment
402 -> Bool -- ^ attempt linking in batch mode?
403 -> HomePackageTable -- ^ what to link
404 -> IO SuccessFlag
405
406 link' logger tmpfs dflags unit_env batch_attempt_linking hpt
407 | batch_attempt_linking
408 = do
409 let
410 staticLink = case ghcLink dflags of
411 LinkStaticLib -> True
412 _ -> False
413
414 home_mod_infos = eltsHpt hpt
415
416 -- the packages we depend on
417 pkg_deps = Set.toList
418 $ Set.unions
419 $ fmap (dep_direct_pkgs . mi_deps . hm_iface)
420 $ home_mod_infos
421
422 -- the linkables to link
423 linkables = map (expectJust "link".hm_linkable) home_mod_infos
424
425 debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
426
427 -- check for the -no-link flag
428 if isNoLink (ghcLink dflags)
429 then do debugTraceMsg logger 3 (text "link(batch): linking omitted (-c flag given).")
430 return Succeeded
431 else do
432
433 let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked)
434 obj_files = concatMap getOfiles linkables
435 platform = targetPlatform dflags
436 exe_file = exeFileName platform staticLink (outputFile_ dflags)
437
438 linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps
439
440 if not (gopt Opt_ForceRecomp dflags) && not linking_needed
441 then do debugTraceMsg logger 2 (text exe_file <+> text "is up to date, linking not required.")
442 return Succeeded
443 else do
444
445 compilationProgressMsg logger (text "Linking " <> text exe_file <> text " ...")
446
447 -- Don't showPass in Batch mode; doLink will do that for us.
448 let link = case ghcLink dflags of
449 LinkBinary -> linkBinary logger tmpfs
450 LinkStaticLib -> linkStaticLib logger
451 LinkDynLib -> linkDynLibCheck logger tmpfs
452 other -> panicBadLink other
453 link dflags unit_env obj_files pkg_deps
454
455 debugTraceMsg logger 3 (text "link: done")
456
457 -- linkBinary only returns if it succeeds
458 return Succeeded
459
460 | otherwise
461 = do debugTraceMsg logger 3 (text "link(batch): upsweep (partially) failed OR" $$
462 text " Main.main not exported; not linking.")
463 return Succeeded
464
465
466 linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool
467 linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
468 -- if the modification time on the executable is later than the
469 -- modification times on all of the objects and libraries, then omit
470 -- linking (unless the -fforce-recomp flag was given).
471 let platform = ue_platform unit_env
472 unit_state = ue_units unit_env
473 exe_file = exeFileName platform staticLink (outputFile_ dflags)
474 e_exe_time <- tryIO $ getModificationUTCTime exe_file
475 case e_exe_time of
476 Left _ -> return True
477 Right t -> do
478 -- first check object files and extra_ld_inputs
479 let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
480 e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs
481 let (errs,extra_times) = partitionEithers e_extra_times
482 let obj_times = map linkableTime linkables ++ extra_times
483 if not (null errs) || any (t <) obj_times
484 then return True
485 else do
486
487 -- next, check libraries. XXX this only checks Haskell libraries,
488 -- not extra_libraries or -l things from the command line.
489 let pkg_hslibs = [ (collectLibraryDirs (ways dflags) [c], lib)
490 | Just c <- map (lookupUnitId unit_state) pkg_deps,
491 lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ]
492
493 pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs
494 if any isNothing pkg_libfiles then return True else do
495 e_lib_times <- mapM (tryIO . getModificationUTCTime)
496 (catMaybes pkg_libfiles)
497 let (lib_errs,lib_times) = partitionEithers e_lib_times
498 if not (null lib_errs) || any (t <) lib_times
499 then return True
500 else checkLinkInfo logger dflags unit_env pkg_deps exe_file
501
502 findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath)
503 findHSLib platform ws dirs lib = do
504 let batch_lib_file = if ws `hasNotWay` WayDyn
505 then "lib" ++ lib <.> "a"
506 else platformSOName platform lib
507 found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
508 case found of
509 [] -> return Nothing
510 (x:_) -> return (Just x)
511
512 -- -----------------------------------------------------------------------------
513 -- Compile files in one-shot mode.
514
515 oneShot :: HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO ()
516 oneShot hsc_env stop_phase srcs = do
517 o_files <- mapMaybeM (compileFile hsc_env stop_phase) srcs
518 case stop_phase of
519 StopPreprocess -> return ()
520 StopC -> return ()
521 StopAs -> return ()
522 NoStop -> doLink hsc_env o_files
523
524 compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath)
525 compileFile hsc_env stop_phase (src, _mb_phase) = do
526 exists <- doesFileExist src
527 when (not exists) $
528 throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))
529
530 let
531 dflags = hsc_dflags hsc_env
532 mb_o_file = outputFile dflags
533 ghc_link = ghcLink dflags -- Set by -c or -no-link
534 notStopPreprocess | StopPreprocess <- stop_phase = False
535 | _ <- stop_phase = True
536 -- When linking, the -o argument refers to the linker's output.
537 -- otherwise, we use it as the name for the pipeline's output.
538 output
539 | NoBackend <- backend dflags, notStopPreprocess = NoOutputFile
540 -- avoid -E -fno-code undesirable interactions. see #20439
541 | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent
542 -- -o foo applies to linker
543 | isJust mb_o_file = SpecificFile
544 -- -o foo applies to the file we are compiling now
545 | otherwise = Persistent
546 pipe_env = mkPipeEnv stop_phase src output
547 pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src
548 runPipeline (hsc_hooks hsc_env) pipeline
549
550
551 doLink :: HscEnv -> [FilePath] -> IO ()
552 doLink hsc_env o_files =
553 let
554 dflags = hsc_dflags hsc_env
555 logger = hsc_logger hsc_env
556 unit_env = hsc_unit_env hsc_env
557 tmpfs = hsc_tmpfs hsc_env
558 in case ghcLink dflags of
559 NoLink -> return ()
560 LinkBinary -> linkBinary logger tmpfs dflags unit_env o_files []
561 LinkStaticLib -> linkStaticLib logger dflags unit_env o_files []
562 LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env o_files []
563 other -> panicBadLink other
564
565 -----------------------------------------------------------------------------
566 -- stub .h and .c files (for foreign export support), and cc files.
567
568 -- The _stub.c file is derived from the haskell source file, possibly taking
569 -- into account the -stubdir option.
570 --
571 -- The object file created by compiling the _stub.c file is put into a
572 -- temporary file, which will be later combined with the main .o file
573 -- (see the MergeForeigns phase).
574 --
575 -- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files
576 -- from TH, that are then compiled and linked to the module. This is
577 -- useful to implement facilities such as inline-c.
578
579 compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
580 compileForeign _ RawObject object_file = return object_file
581 compileForeign hsc_env lang stub_c = do
582 let pipeline = case lang of
583 LangC -> viaCPipeline Cc
584 LangCxx -> viaCPipeline Ccxx
585 LangObjc -> viaCPipeline Cobjc
586 LangObjcxx -> viaCPipeline Cobjcxx
587 LangAsm -> \pe hsc_env ml fp -> Just <$> asPipeline True pe hsc_env ml fp
588 #if __GLASGOW_HASKELL__ < 811
589 RawObject -> panic "compileForeign: should be unreachable"
590 #endif
591 pipe_env = mkPipeEnv NoStop stub_c (Temporary TFL_GhcSession)
592 res <- runPipeline (hsc_hooks hsc_env) (pipeline pipe_env hsc_env Nothing stub_c)
593 case res of
594 -- This should never happen as viaCPipeline should only return `Nothing` when the stop phase is `StopC`.
595 -- Future refactoring to not check StopC for this case
596 Nothing -> pprPanic "compileForeign" (ppr stub_c)
597 Just fp -> return fp
598
599 compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
600 compileEmptyStub dflags hsc_env basename location mod_name = do
601 -- To maintain the invariant that every Haskell file
602 -- compiles to object code, we make an empty (but
603 -- valid) stub object file for signatures. However,
604 -- we make sure this object file has a unique symbol,
605 -- so that ranlib on OS X doesn't complain, see
606 -- https://gitlab.haskell.org/ghc/ghc/issues/12673
607 -- and https://github.com/haskell/cabal/issues/2257
608 let logger = hsc_logger hsc_env
609 let tmpfs = hsc_tmpfs hsc_env
610 empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
611 let home_unit = hsc_home_unit hsc_env
612 src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
613 writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
614 let pipe_env = (mkPipeEnv NoStop empty_stub Persistent) { src_basename = basename}
615 pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub
616 _ <- runPipeline (hsc_hooks hsc_env) pipeline
617 return ()
618
619
620 {- Environment Initialisation -}
621
622 mkPipeEnv :: StopPhase -- End phase
623 -> FilePath -- input fn
624 -> PipelineOutput -- Output
625 -> PipeEnv
626 mkPipeEnv stop_phase input_fn output =
627 let (basename, suffix) = splitExtension input_fn
628 suffix' = drop 1 suffix -- strip off the .
629 env = PipeEnv{ stop_phase,
630 src_filename = input_fn,
631 src_basename = basename,
632 src_suffix = suffix',
633 output_spec = output }
634 in env
635
636 setDumpPrefix :: PipeEnv -> HscEnv -> HscEnv
637 setDumpPrefix pipe_env hsc_env =
638 hscUpdateFlags (\dflags -> dflags { dumpPrefix = Just (src_basename pipe_env ++ ".")}) hsc_env
639
640 {- The Pipelines -}
641
642 phaseIfFlag :: Monad m
643 => HscEnv
644 -> (DynFlags -> Bool)
645 -> a
646 -> m a
647 -> m a
648 phaseIfFlag hsc_env flag def action =
649 if flag (hsc_dflags hsc_env)
650 then action
651 else return def
652
653 -- | Check if the start is *before* the current phase, otherwise skip with a default
654 phaseIfAfter :: P m => Platform -> Phase -> Phase -> a -> m a -> m a
655 phaseIfAfter platform start_phase cur_phase def action =
656 if start_phase `eqPhase` cur_phase
657 || happensBefore platform start_phase cur_phase
658
659 then action
660 else return def
661
662 -- | The preprocessor pipeline
663 preprocessPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (DynFlags, FilePath)
664 preprocessPipeline pipe_env hsc_env input_fn = do
665 unlit_fn <-
666 runAfter (Unlit HsSrcFile) input_fn $ do
667 use (T_Unlit pipe_env hsc_env input_fn)
668
669
670 (dflags1, warns1) <- use (T_FileArgs hsc_env unlit_fn)
671 let hsc_env1 = hscSetFlags dflags1 hsc_env
672
673 (cpp_fn, hsc_env2)
674 <- runAfterFlag hsc_env1 (Cpp HsSrcFile) (xopt LangExt.Cpp) (unlit_fn, hsc_env1) $ do
675 cpp_fn <- use (T_Cpp pipe_env hsc_env1 unlit_fn)
676 (dflags2, _) <- use (T_FileArgs hsc_env1 cpp_fn)
677 let hsc_env2 = hscSetFlags dflags2 hsc_env1
678 return (cpp_fn, hsc_env2)
679
680
681 pp_fn <- runAfterFlag hsc_env2 (HsPp HsSrcFile) (gopt Opt_Pp) cpp_fn $
682 use (T_HsPp pipe_env hsc_env2 input_fn cpp_fn)
683
684 (dflags3, warns3)
685 <- if pp_fn == unlit_fn
686 -- Didn't run any preprocessors so don't need to reparse, would be nicer
687 -- if `T_FileArgs` recognised this.
688 then return (dflags1, warns1)
689 else do
690 -- Reparse with original hsc_env so that we don't get duplicated options
691 use (T_FileArgs hsc_env pp_fn)
692
693 liftIO (handleFlagWarnings (hsc_logger hsc_env) (initDiagOpts dflags3) warns3)
694 return (dflags3, pp_fn)
695
696
697 -- This won't change through the compilation pipeline
698 where platform = targetPlatform (hsc_dflags hsc_env)
699 runAfter :: P p => Phase
700 -> a -> p a -> p a
701 runAfter = phaseIfAfter platform start_phase
702 start_phase = startPhase (src_suffix pipe_env)
703 runAfterFlag :: P p
704 => HscEnv
705 -> Phase
706 -> (DynFlags -> Bool)
707 -> a
708 -> p a
709 -> p a
710 runAfterFlag hsc_env phase flag def action =
711 runAfter phase def
712 $ phaseIfFlag hsc_env flag def action
713
714 -- | The complete compilation pipeline, from start to finish
715 fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, Maybe Linkable)
716 fullPipeline pipe_env hsc_env pp_fn src_flavour = do
717 (dflags, input_fn) <- preprocessPipeline pipe_env hsc_env pp_fn
718 let hsc_env' = hscSetFlags dflags hsc_env
719 (hsc_env_with_plugins, mod_sum, hsc_recomp_status)
720 <- use (T_HscRecomp pipe_env hsc_env' input_fn src_flavour)
721 hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status)
722
723 -- | Everything after preprocess
724 hscPipeline :: P m => PipeEnv -> ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, Maybe Linkable)
725 hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do
726 case hsc_recomp_status of
727 HscUpToDate iface mb_linkable -> return (iface, mb_linkable)
728 HscRecompNeeded mb_old_hash -> do
729 (tc_result, warnings) <- use (T_Hsc hsc_env_with_plugins mod_sum)
730 hscBackendAction <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash )
731 hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum hscBackendAction
732
733 hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, Maybe Linkable)
734 hscBackendPipeline pipe_env hsc_env mod_sum result =
735 case backend (hsc_dflags hsc_env) of
736 NoBackend ->
737 case result of
738 HscUpdate iface -> return (iface, Nothing)
739 HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing) <*> pure Nothing
740 -- TODO: Why is there not a linkable?
741 -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing
742 _ -> do
743 res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result
744 when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env)) $ do
745 let dflags' = setDynamicNow (hsc_dflags hsc_env) -- set "dynamicNow"
746 () <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result
747 return res
748
749 hscGenBackendPipeline :: P m
750 => PipeEnv
751 -> HscEnv
752 -> ModSummary
753 -> HscBackendAction
754 -> m (ModIface, Maybe Linkable)
755 hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
756 let mod_name = moduleName (ms_mod mod_sum)
757 src_flavour = (ms_hsc_src mod_sum)
758 let location = ms_location mod_sum
759 (fos, miface, mlinkable, o_file) <- use (T_HscBackend pipe_env hsc_env mod_name src_flavour location result)
760 final_fp <- hscPostBackendPipeline pipe_env hsc_env (ms_hsc_src mod_sum) (backend (hsc_dflags hsc_env)) (Just location) o_file
761 final_linkable <-
762 case final_fp of
763 -- No object file produced, bytecode or NoBackend
764 Nothing -> return mlinkable
765 Just o_fp -> do
766 unlinked_time <- liftIO (liftIO getCurrentTime)
767 final_o <- use (T_MergeForeign pipe_env hsc_env (Just location) o_fp fos)
768 let !linkable = LM unlinked_time
769 (ms_mod mod_sum)
770 [DotO final_o]
771 return (Just linkable)
772 return (miface, final_linkable)
773
774 asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
775 asPipeline use_cpp pipe_env hsc_env location input_fn = do
776 use (T_As use_cpp pipe_env hsc_env location input_fn)
777
778 viaCPipeline :: P m => Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
779 viaCPipeline c_phase pipe_env hsc_env location input_fn = do
780 out_fn <- use (T_Cc c_phase pipe_env hsc_env input_fn)
781 case stop_phase pipe_env of
782 StopC -> return Nothing
783 _ -> Just <$> asPipeline False pipe_env hsc_env location out_fn
784
785 llvmPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
786 llvmPipeline pipe_env hsc_env location fp = do
787 opt_fn <- use (T_LlvmOpt pipe_env hsc_env fp)
788 llvmLlcPipeline pipe_env hsc_env location opt_fn
789
790 llvmLlcPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
791 llvmLlcPipeline pipe_env hsc_env location opt_fn = do
792 llc_fn <- use (T_LlvmLlc pipe_env hsc_env opt_fn)
793 llvmManglePipeline pipe_env hsc_env location llc_fn
794
795 llvmManglePipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
796 llvmManglePipeline pipe_env hsc_env location llc_fn = do
797 mangled_fn <-
798 if gopt Opt_NoLlvmMangler (hsc_dflags hsc_env)
799 then use (T_LlvmMangle pipe_env hsc_env llc_fn)
800 else return llc_fn
801 asPipeline False pipe_env hsc_env location mangled_fn
802
803 cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath
804 cmmCppPipeline pipe_env hsc_env input_fn = do
805 output_fn <- use (T_CmmCpp pipe_env hsc_env input_fn)
806 cmmPipeline pipe_env hsc_env output_fn
807
808 cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath
809 cmmPipeline pipe_env hsc_env input_fn = do
810 (fos, output_fn) <- use (T_Cmm pipe_env hsc_env input_fn)
811 mo_fn <- hscPostBackendPipeline pipe_env hsc_env HsSrcFile (backend (hsc_dflags hsc_env)) Nothing output_fn
812 case mo_fn of
813 Nothing -> panic "CMM pipeline - produced no .o file"
814 Just mo_fn -> use (T_MergeForeign pipe_env hsc_env Nothing mo_fn fos)
815
816 hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
817 hscPostBackendPipeline _ _ HsBootFile _ _ _ = return Nothing
818 hscPostBackendPipeline _ _ HsigFile _ _ _ = return Nothing
819 hscPostBackendPipeline pipe_env hsc_env _ bcknd ml input_fn =
820 case bcknd of
821 ViaC -> viaCPipeline HCc pipe_env hsc_env ml input_fn
822 NCG -> Just <$> asPipeline False pipe_env hsc_env ml input_fn
823 LLVM -> Just <$> llvmPipeline pipe_env hsc_env ml input_fn
824 NoBackend -> return Nothing
825 Interpreter -> return Nothing
826
827 -- Pipeline from a given suffix
828 pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
829 pipelineStart pipe_env hsc_env input_fn =
830 fromSuffix (src_suffix pipe_env)
831 where
832 stop_after = stop_phase pipe_env
833 frontend :: P m => HscSource -> m (Maybe FilePath)
834 frontend sf = case stop_after of
835 StopPreprocess -> do
836 -- The actual output from preprocessing
837 (_, out_fn) <- preprocessPipeline pipe_env hsc_env input_fn
838 let logger = hsc_logger hsc_env
839 -- Sometimes, a compilation phase doesn't actually generate any output
840 -- (eg. the CPP phase when -fcpp is not turned on). If we end on this
841 -- stage, but we wanted to keep the output, then we have to explicitly
842 -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
843 -- further compilation stages can tell what the original filename was.
844 -- File name we expected the output to have
845 final_fn <- liftIO $ phaseOutputFilenameNew (Hsc HsSrcFile) pipe_env hsc_env Nothing
846 when (final_fn /= out_fn) $ do
847 let msg = "Copying `" ++ out_fn ++"' to `" ++ final_fn ++ "'"
848 line_prag = "{-# LINE 1 \"" ++ src_filename pipe_env ++ "\" #-}\n"
849 liftIO (showPass logger msg)
850 liftIO (copyWithHeader line_prag out_fn final_fn)
851 return Nothing
852 _ -> objFromLinkable <$> fullPipeline pipe_env hsc_env input_fn sf
853 c :: P m => Phase -> m (Maybe FilePath)
854 c phase = viaCPipeline phase pipe_env hsc_env Nothing input_fn
855 as :: P m => Bool -> m (Maybe FilePath)
856 as use_cpp = Just <$> asPipeline use_cpp pipe_env hsc_env Nothing input_fn
857
858 objFromLinkable (_, Just (LM _ _ [DotO lnk])) = Just lnk
859 objFromLinkable _ = Nothing
860
861
862 fromSuffix :: P m => String -> m (Maybe FilePath)
863 fromSuffix "lhs" = frontend HsSrcFile
864 fromSuffix "lhs-boot" = frontend HsBootFile
865 fromSuffix "lhsig" = frontend HsigFile
866 fromSuffix "hs" = frontend HsSrcFile
867 fromSuffix "hs-boot" = frontend HsBootFile
868 fromSuffix "hsig" = frontend HsigFile
869 fromSuffix "hscpp" = frontend HsSrcFile
870 fromSuffix "hspp" = frontend HsSrcFile
871 fromSuffix "hc" = c HCc
872 fromSuffix "c" = c Cc
873 fromSuffix "cpp" = c Ccxx
874 fromSuffix "C" = c Cc
875 fromSuffix "m" = c Cobjc
876 fromSuffix "M" = c Cobjcxx
877 fromSuffix "mm" = c Cobjcxx
878 fromSuffix "cc" = c Ccxx
879 fromSuffix "cxx" = c Ccxx
880 fromSuffix "s" = as False
881 fromSuffix "S" = as True
882 fromSuffix "ll" = Just <$> llvmPipeline pipe_env hsc_env Nothing input_fn
883 fromSuffix "bc" = Just <$> llvmLlcPipeline pipe_env hsc_env Nothing input_fn
884 fromSuffix "lm_s" = Just <$> llvmManglePipeline pipe_env hsc_env Nothing input_fn
885 fromSuffix "o" = return (Just input_fn)
886 fromSuffix "cmm" = Just <$> cmmCppPipeline pipe_env hsc_env input_fn
887 fromSuffix "cmmcpp" = Just <$> cmmPipeline pipe_env hsc_env input_fn
888 fromSuffix _ = return (Just input_fn)
889
890 {-
891
892 Note [The Pipeline Monad]
893 ~~~~~~~~~~~~~~~~~~~~~~~~~
894
895 The pipeline is represented as a free monad by the `TPipelineClass` type synonym,
896 which stipulates the general monadic interface for the pipeline and `MonadUse`, instantiated
897 to `TPhase`, which indicates the actions available in the pipeline.
898
899 The `TPhase` actions correspond to different compiled phases, they are executed by
900 the 'runPhase' function which interprets each action into IO.
901
902 The idea in the future is that we can now implement different instiations of
903 `TPipelineClass` to give different behaviours that the default `HookedPhase` implementation:
904
905 * Additional logging of different phases
906 * Automatic parrelism (in the style of shake)
907 * Easy consumption by external tools such as ghcide
908 * Easier to create your own pipeline and extend existing pipelines.
909
910 The structure of the code as a free monad also means that the return type of each
911 phase is a lot more flexible.
912
913 -}