never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE TupleSections, RecordWildCards #-}
3 {-# LANGUAGE BangPatterns #-}
4 {-# LANGUAGE LambdaCase #-}
5
6 --
7 -- (c) The University of Glasgow 2002-2006
8
9 -- | The loader
10 --
11 -- This module deals with the top-level issues of dynamic linking (loading),
12 -- calling the object-code linker and the byte-code linker where necessary.
13 module GHC.Linker.Loader
14 ( Loader (..)
15 , LoaderState (..)
16 , initLoaderState
17 , uninitializedLoader
18 , showLoaderState
19 , getLoaderState
20 -- * Load & Unload
21 , loadExpr
22 , loadDecls
23 , loadPackages
24 , loadModule
25 , loadCmdLineLibs
26 , loadName
27 , unload
28 -- * LoadedEnv
29 , withExtendedLoadedEnv
30 , extendLoadedEnv
31 , deleteFromLoadedEnv
32 -- * Misc
33 , extendLoadedPkgs
34 )
35 where
36
37 import GHC.Prelude
38
39 import GHC.Settings
40
41 import GHC.Platform
42 import GHC.Platform.Ways
43
44 import GHC.Driver.Phases
45 import GHC.Driver.Env
46 import GHC.Driver.Session
47 import GHC.Driver.Ppr
48 import GHC.Driver.Config
49 import GHC.Driver.Config.Diagnostic
50 import GHC.Driver.Config.Finder
51
52 import GHC.Tc.Utils.Monad
53
54 import GHC.Runtime.Interpreter
55 import GHCi.RemoteTypes
56
57 import GHC.Iface.Load
58
59 import GHC.ByteCode.Linker
60 import GHC.ByteCode.Asm
61 import GHC.ByteCode.Types
62
63 import GHC.SysTools
64
65 import GHC.Types.Basic
66 import GHC.Types.Name
67 import GHC.Types.Name.Env
68 import GHC.Types.SrcLoc
69 import GHC.Types.Unique.DSet
70
71 import GHC.Utils.Outputable
72 import GHC.Utils.Panic
73 import GHC.Utils.Panic.Plain
74 import GHC.Utils.Constants (isWindowsHost, isDarwinHost)
75 import GHC.Utils.Misc
76 import GHC.Utils.Error
77 import GHC.Utils.Logger
78 import GHC.Utils.TmpFs
79
80 import GHC.Unit.Env
81 import GHC.Unit.Finder
82 import GHC.Unit.Module
83 import GHC.Unit.Module.ModIface
84 import GHC.Unit.Module.Deps
85 import GHC.Unit.Home
86 import GHC.Unit.Home.ModInfo
87 import GHC.Unit.State as Packages
88
89 import qualified GHC.Data.ShortText as ST
90 import qualified GHC.Data.Maybe as Maybes
91 import GHC.Data.FastString
92 import GHC.Data.List.SetOps
93
94 import GHC.Linker.MacOS
95 import GHC.Linker.Dynamic
96 import GHC.Linker.Types
97
98 -- Standard libraries
99 import Control.Monad
100
101 import qualified Data.Set as Set
102 import Data.Char (isSpace)
103 import Data.IORef
104 import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition, find)
105 import Data.Maybe
106 import Control.Concurrent.MVar
107 import qualified Control.Monad.Catch as MC
108
109 import System.FilePath
110 import System.Directory
111 import System.IO.Unsafe
112 import System.Environment (lookupEnv)
113
114 #if defined(mingw32_HOST_OS)
115 import System.Win32.Info (getSystemDirectory)
116 #endif
117
118 import GHC.Utils.Exception
119 import qualified Data.Map as M
120 import Data.Either (partitionEithers)
121
122 uninitialised :: a
123 uninitialised = panic "Loader not initialised"
124
125 modifyLoaderState_ :: Interp -> (LoaderState -> IO LoaderState) -> IO ()
126 modifyLoaderState_ interp f =
127 modifyMVar_ (loader_state (interpLoader interp))
128 (fmap pure . f . fromMaybe uninitialised)
129
130 modifyLoaderState :: Interp -> (LoaderState -> IO (LoaderState, a)) -> IO a
131 modifyLoaderState interp f =
132 modifyMVar (loader_state (interpLoader interp))
133 (fmapFst pure . f . fromMaybe uninitialised)
134 where fmapFst f = fmap (\(x, y) -> (f x, y))
135
136 getLoaderState :: Interp -> IO (Maybe LoaderState)
137 getLoaderState interp = readMVar (loader_state (interpLoader interp))
138
139
140 emptyLoaderState :: LoaderState
141 emptyLoaderState = LoaderState
142 { closure_env = emptyNameEnv
143 , itbl_env = emptyNameEnv
144 , pkgs_loaded = init_pkgs
145 , bcos_loaded = []
146 , objs_loaded = []
147 , hs_objs_loaded = []
148 , non_hs_objs_loaded = []
149 , module_deps = M.empty
150 , temp_sos = []
151 }
152 -- Packages that don't need loading, because the compiler
153 -- shares them with the interpreted program.
154 --
155 -- The linker's symbol table is populated with RTS symbols using an
156 -- explicit list. See rts/Linker.c for details.
157 where init_pkgs = [rtsUnitId]
158
159 extendLoadedPkgs :: Interp -> [UnitId] -> IO ()
160 extendLoadedPkgs interp pkgs =
161 modifyLoaderState_ interp $ \s ->
162 return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
163
164 extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO ()
165 extendLoadedEnv interp new_bindings =
166 modifyLoaderState_ interp $ \pls@LoaderState{..} -> do
167 let new_ce = extendClosureEnv closure_env new_bindings
168 return $! pls{ closure_env = new_ce }
169 -- strictness is important for not retaining old copies of the pls
170
171 deleteFromLoadedEnv :: Interp -> [Name] -> IO ()
172 deleteFromLoadedEnv interp to_remove =
173 modifyLoaderState_ interp $ \pls -> do
174 let ce = closure_env pls
175 let new_ce = delListFromNameEnv ce to_remove
176 return pls{ closure_env = new_ce }
177
178 -- | Load the module containing the given Name and get its associated 'HValue'.
179 --
180 -- Throws a 'ProgramError' if loading fails or the name cannot be found.
181 loadName :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Name -> IO ForeignHValue
182 loadName interp hsc_env mnwib name = do
183 initLoaderState interp hsc_env
184 modifyLoaderState interp $ \pls0 -> do
185 pls <- if not (isExternalName name)
186 then return pls0
187 else do
188 (pls', ok) <- loadDependencies interp hsc_env pls0 (noSrcSpan, mnwib)
189 [nameModule name]
190 if failed ok
191 then throwGhcExceptionIO (ProgramError "")
192 else return pls'
193
194 case lookupNameEnv (closure_env pls) name of
195 Just (_,aa) -> return (pls,aa)
196 Nothing -> assertPpr (isExternalName name) (ppr name) $
197 do let sym_to_find = nameToCLabel name "closure"
198 m <- lookupClosure interp (unpackFS sym_to_find)
199 r <- case m of
200 Just hvref -> mkFinalizedHValue interp hvref
201 Nothing -> linkFail "GHC.Linker.Loader.loadName"
202 (unpackFS sym_to_find)
203 return (pls,r)
204
205 loadDependencies
206 :: Interp
207 -> HscEnv
208 -> LoaderState
209 -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> [Module]
210 -> IO (LoaderState, SuccessFlag)
211 loadDependencies interp hsc_env pls span needed_mods = do
212 -- initLoaderState (hsc_dflags hsc_env) dl
213 let hpt = hsc_HPT hsc_env
214 let dflags = hsc_dflags hsc_env
215 -- The interpreter and dynamic linker can only handle object code built
216 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
217 -- So here we check the build tag: if we're building a non-standard way
218 -- then we need to find & link object files built the "normal" way.
219 maybe_normal_osuf <- checkNonStdWay dflags interp (fst span)
220
221 -- Find what packages and linkables are required
222 (lnks, all_lnks, pkgs) <- getLinkDeps hsc_env hpt pls
223 maybe_normal_osuf (fst span) needed_mods
224
225 let pls1 =
226 case (snd span) of
227 Just mn -> pls { module_deps = M.insertWith (++) mn all_lnks (module_deps pls) }
228 Nothing -> pls
229
230 -- Link the packages and modules required
231 pls2 <- loadPackages' interp hsc_env pkgs pls1
232 loadModules interp hsc_env pls2 lnks
233
234
235 -- | Temporarily extend the loaded env.
236 withExtendedLoadedEnv
237 :: (ExceptionMonad m)
238 => Interp
239 -> [(Name,ForeignHValue)]
240 -> m a
241 -> m a
242 withExtendedLoadedEnv interp new_env action
243 = MC.bracket (liftIO $ extendLoadedEnv interp new_env)
244 (\_ -> reset_old_env)
245 (\_ -> action)
246 where
247 -- Remember that the linker state might be side-effected
248 -- during the execution of the IO action, and we don't want to
249 -- lose those changes (we might have linked a new module or
250 -- package), so the reset action only removes the names we
251 -- added earlier.
252 reset_old_env = liftIO $
253 modifyLoaderState_ interp $ \pls ->
254 let cur = closure_env pls
255 new = delListFromNameEnv cur (map fst new_env)
256 in return pls{ closure_env = new }
257
258
259 -- | Display the loader state.
260 showLoaderState :: Interp -> IO SDoc
261 showLoaderState interp = do
262 ls <- readMVar (loader_state (interpLoader interp))
263 let docs = case ls of
264 Nothing -> [ text "Loader not initialised"]
265 Just pls -> [ text "Pkgs:" <+> ppr (pkgs_loaded pls)
266 , text "Objs:" <+> ppr (objs_loaded pls)
267 , text "BCOs:" <+> ppr (bcos_loaded pls)
268 ]
269
270 return $ withPprStyle defaultDumpStyle
271 $ vcat (text "----- Loader state -----":docs)
272
273
274 {- **********************************************************************
275
276 Initialisation
277
278 ********************************************************************* -}
279
280 -- | Initialise the dynamic linker. This entails
281 --
282 -- a) Calling the C initialisation procedure,
283 --
284 -- b) Loading any packages specified on the command line,
285 --
286 -- c) Loading any packages specified on the command line, now held in the
287 -- @-l@ options in @v_Opt_l@,
288 --
289 -- d) Loading any @.o\/.dll@ files specified on the command line, now held
290 -- in @ldInputs@,
291 --
292 -- e) Loading any MacOS frameworks.
293 --
294 -- NOTE: This function is idempotent; if called more than once, it does
295 -- nothing. This is useful in Template Haskell, where we call it before
296 -- trying to link.
297 --
298 initLoaderState :: Interp -> HscEnv -> IO ()
299 initLoaderState interp hsc_env = do
300 modifyMVar_ (loader_state (interpLoader interp)) $ \pls -> do
301 case pls of
302 Just _ -> return pls
303 Nothing -> Just <$> reallyInitLoaderState interp hsc_env
304
305 reallyInitLoaderState :: Interp -> HscEnv -> IO LoaderState
306 reallyInitLoaderState interp hsc_env = do
307 -- Initialise the linker state
308 let pls0 = emptyLoaderState
309
310 -- (a) initialise the C dynamic linker
311 initObjLinker interp
312
313 -- (b) Load packages from the command-line (Note [preload packages])
314 pls <- loadPackages' interp hsc_env (preloadUnits (hsc_units hsc_env)) pls0
315
316 -- steps (c), (d) and (e)
317 loadCmdLineLibs' interp hsc_env pls
318
319
320 loadCmdLineLibs :: Interp -> HscEnv -> IO ()
321 loadCmdLineLibs interp hsc_env = do
322 initLoaderState interp hsc_env
323 modifyLoaderState_ interp $ \pls ->
324 loadCmdLineLibs' interp hsc_env pls
325
326 loadCmdLineLibs'
327 :: Interp
328 -> HscEnv
329 -> LoaderState
330 -> IO LoaderState
331 loadCmdLineLibs' interp hsc_env pls =
332 do
333 let dflags@(DynFlags { ldInputs = cmdline_ld_inputs
334 , libraryPaths = lib_paths_base})
335 = hsc_dflags hsc_env
336 let logger = hsc_logger hsc_env
337
338 -- (c) Link libraries from the command-line
339 let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]
340
341 -- On Windows we want to add libpthread by default just as GCC would.
342 -- However because we don't know the actual name of pthread's dll we
343 -- need to defer this to the locateLib call so we can't initialize it
344 -- inside of the rts. Instead we do it here to be able to find the
345 -- import library for pthreads. See #13210.
346 let platform = targetPlatform dflags
347 os = platformOS platform
348 minus_ls = case os of
349 OSMinGW32 -> "pthread" : minus_ls_1
350 _ -> minus_ls_1
351 -- See Note [Fork/Exec Windows]
352 gcc_paths <- getGCCPaths logger dflags os
353
354 lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base
355
356 maybePutStrLn logger "Search directories (user):"
357 maybePutStr logger (unlines $ map (" "++) lib_paths_env)
358 maybePutStrLn logger "Search directories (gcc):"
359 maybePutStr logger (unlines $ map (" "++) gcc_paths)
360
361 libspecs
362 <- mapM (locateLib interp hsc_env False lib_paths_env gcc_paths) minus_ls
363
364 -- (d) Link .o files from the command-line
365 classified_ld_inputs <- mapM (classifyLdInput logger platform)
366 [ f | FileOption _ f <- cmdline_ld_inputs ]
367
368 -- (e) Link any MacOS frameworks
369 let platform = targetPlatform dflags
370 let (framework_paths, frameworks) =
371 if platformUsesFrameworks platform
372 then (frameworkPaths dflags, cmdlineFrameworks dflags)
373 else ([],[])
374
375 -- Finally do (c),(d),(e)
376 let cmdline_lib_specs = catMaybes classified_ld_inputs
377 ++ libspecs
378 ++ map Framework frameworks
379 if null cmdline_lib_specs
380 then return pls
381 else do
382 -- Add directories to library search paths, this only has an effect
383 -- on Windows. On Unix OSes this function is a NOP.
384 let all_paths = let paths = takeDirectory (pgm_c dflags)
385 : framework_paths
386 ++ lib_paths_base
387 ++ [ takeDirectory dll | DLLPath dll <- libspecs ]
388 in nub $ map normalise paths
389 let lib_paths = nub $ lib_paths_base ++ gcc_paths
390 all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
391 pathCache <- mapM (addLibrarySearchPath interp) all_paths_env
392
393 let merged_specs = mergeStaticObjects cmdline_lib_specs
394 pls1 <- foldM (preloadLib interp hsc_env lib_paths framework_paths) pls
395 merged_specs
396
397 maybePutStr logger "final link ... "
398 ok <- resolveObjs interp
399
400 -- DLLs are loaded, reset the search paths
401 mapM_ (removeLibrarySearchPath interp) $ reverse pathCache
402
403 if succeeded ok then maybePutStrLn logger "done"
404 else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
405
406 return pls1
407
408 -- | Merge runs of consecutive of 'Objects'. This allows for resolution of
409 -- cyclic symbol references when dynamically linking. Specifically, we link
410 -- together all of the static objects into a single shared object, avoiding
411 -- the issue we saw in #13786.
412 mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec]
413 mergeStaticObjects specs = go [] specs
414 where
415 go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec]
416 go accum (Objects objs : rest) = go (objs ++ accum) rest
417 go accum@(_:_) rest = Objects (reverse accum) : go [] rest
418 go [] (spec:rest) = spec : go [] rest
419 go [] [] = []
420
421 {- Note [preload packages]
422
423 Why do we need to preload packages from the command line? This is an
424 explanation copied from #2437:
425
426 I tried to implement the suggestion from #3560, thinking it would be
427 easy, but there are two reasons we link in packages eagerly when they
428 are mentioned on the command line:
429
430 * So that you can link in extra object files or libraries that
431 depend on the packages. e.g. ghc -package foo -lbar where bar is a
432 C library that depends on something in foo. So we could link in
433 foo eagerly if and only if there are extra C libs or objects to
434 link in, but....
435
436 * Haskell code can depend on a C function exported by a package, and
437 the normal dependency tracking that TH uses can't know about these
438 dependencies. The test ghcilink004 relies on this, for example.
439
440 I conclude that we need two -package flags: one that says "this is a
441 package I want to make available", and one that says "this is a
442 package I want to link in eagerly". Would that be too complicated for
443 users?
444 -}
445
446 classifyLdInput :: Logger -> Platform -> FilePath -> IO (Maybe LibrarySpec)
447 classifyLdInput logger platform f
448 | isObjectFilename platform f = return (Just (Objects [f]))
449 | isDynLibFilename platform f = return (Just (DLLPath f))
450 | otherwise = do
451 logMsg logger MCInfo noSrcSpan
452 $ withPprStyle defaultUserStyle
453 (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
454 return Nothing
455
456 preloadLib
457 :: Interp
458 -> HscEnv
459 -> [String]
460 -> [String]
461 -> LoaderState
462 -> LibrarySpec
463 -> IO LoaderState
464 preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do
465 maybePutStr logger ("Loading object " ++ showLS lib_spec ++ " ... ")
466 case lib_spec of
467 Objects static_ishs -> do
468 (b, pls1) <- preload_statics lib_paths static_ishs
469 maybePutStrLn logger (if b then "done" else "not found")
470 return pls1
471
472 Archive static_ish -> do
473 b <- preload_static_archive lib_paths static_ish
474 maybePutStrLn logger (if b then "done" else "not found")
475 return pls
476
477 DLL dll_unadorned -> do
478 maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned)
479 case maybe_errstr of
480 Nothing -> maybePutStrLn logger "done"
481 Just mm | platformOS platform /= OSDarwin ->
482 preloadFailed mm lib_paths lib_spec
483 Just mm | otherwise -> do
484 -- As a backup, on Darwin, try to also load a .so file
485 -- since (apparently) some things install that way - see
486 -- ticket #8770.
487 let libfile = ("lib" ++ dll_unadorned) <.> "so"
488 err2 <- loadDLL interp libfile
489 case err2 of
490 Nothing -> maybePutStrLn logger "done"
491 Just _ -> preloadFailed mm lib_paths lib_spec
492 return pls
493
494 DLLPath dll_path -> do
495 do maybe_errstr <- loadDLL interp dll_path
496 case maybe_errstr of
497 Nothing -> maybePutStrLn logger "done"
498 Just mm -> preloadFailed mm lib_paths lib_spec
499 return pls
500
501 Framework framework ->
502 if platformUsesFrameworks (targetPlatform dflags)
503 then do maybe_errstr <- loadFramework interp framework_paths framework
504 case maybe_errstr of
505 Nothing -> maybePutStrLn logger "done"
506 Just mm -> preloadFailed mm framework_paths lib_spec
507 return pls
508 else throwGhcExceptionIO (ProgramError "preloadLib Framework")
509
510 where
511 dflags = hsc_dflags hsc_env
512 logger = hsc_logger hsc_env
513
514 platform = targetPlatform dflags
515
516 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
517 preloadFailed sys_errmsg paths spec
518 = do maybePutStr logger "failed.\n"
519 throwGhcExceptionIO $
520 CmdLineError (
521 "user specified .o/.so/.DLL could not be loaded ("
522 ++ sys_errmsg ++ ")\nWhilst trying to load: "
523 ++ showLS spec ++ "\nAdditional directories searched:"
524 ++ (if null paths then " (none)" else
525 intercalate "\n" (map (" "++) paths)))
526
527 -- Not interested in the paths in the static case.
528 preload_statics _paths names
529 = do b <- or <$> mapM doesFileExist names
530 if not b then return (False, pls)
531 else if hostIsDynamic
532 then do pls1 <- dynLoadObjs interp hsc_env pls names
533 return (True, pls1)
534 else do mapM_ (loadObj interp) names
535 return (True, pls)
536
537 preload_static_archive _paths name
538 = do b <- doesFileExist name
539 if not b then return False
540 else do if hostIsDynamic
541 then throwGhcExceptionIO $
542 CmdLineError dynamic_msg
543 else loadArchive interp name
544 return True
545 where
546 dynamic_msg = unlines
547 [ "User-specified static library could not be loaded ("
548 ++ name ++ ")"
549 , "Loading static libraries is not supported in this configuration."
550 , "Try using a dynamic library instead."
551 ]
552
553
554 {- **********************************************************************
555
556 Link a byte-code expression
557
558 ********************************************************************* -}
559
560 -- | Load a single expression, /including/ first loading packages and
561 -- modules that this expression depends on.
562 --
563 -- Raises an IO exception ('ProgramError') if it can't find a compiled
564 -- version of the dependents to load.
565 --
566 loadExpr :: Interp -> HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> UnlinkedBCO -> IO ForeignHValue
567 loadExpr interp hsc_env span root_ul_bco = do
568 -- Initialise the linker (if it's not been done already)
569 initLoaderState interp hsc_env
570
571 -- Take lock for the actual work.
572 modifyLoaderState interp $ \pls0 -> do
573 -- Load the packages and modules required
574 (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods
575 if failed ok
576 then throwGhcExceptionIO (ProgramError "")
577 else do
578 -- Load the expression itself
579 let ie = itbl_env pls
580 ce = closure_env pls
581
582 -- Load the necessary packages and linkables
583 let nobreakarray = error "no break array"
584 bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]
585 resolved <- linkBCO interp ie ce bco_ix nobreakarray root_ul_bco
586 bco_opts <- initBCOOpts (hsc_dflags hsc_env)
587 [root_hvref] <- createBCOs interp bco_opts [resolved]
588 fhv <- mkFinalizedHValue interp root_hvref
589 return (pls, fhv)
590 where
591 free_names = uniqDSetToList (bcoFreeNames root_ul_bco)
592
593 needed_mods :: [Module]
594 needed_mods = [ nameModule n | n <- free_names,
595 isExternalName n, -- Names from other modules
596 not (isWiredInName n) -- Exclude wired-in names
597 ] -- (see note below)
598 -- Exclude wired-in names because we may not have read
599 -- their interface files, so getLinkDeps will fail
600 -- All wired-in names are in the base package, which we link
601 -- by default, so we can safely ignore them here.
602
603 dieWith :: DynFlags -> SrcSpan -> SDoc -> IO a
604 dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage MCFatal span msg)))
605
606
607 checkNonStdWay :: DynFlags -> Interp -> SrcSpan -> IO (Maybe FilePath)
608 checkNonStdWay dflags interp srcspan
609 | ExternalInterp {} <- interpInstance interp = return Nothing
610 -- with -fexternal-interpreter we load the .o files, whatever way
611 -- they were built. If they were built for a non-std way, then
612 -- we will use the appropriate variant of the iserv binary to load them.
613
614 | hostFullWays == targetFullWays = return Nothing
615 -- Only if we are compiling with the same ways as GHC is built
616 -- with, can we dynamically load those object files. (see #3604)
617
618 | objectSuf_ dflags == normalObjectSuffix && not (null targetFullWays)
619 = failNonStd dflags srcspan
620
621 | otherwise = return (Just (hostWayTag ++ "o"))
622 where
623 targetFullWays = fullWays (ways dflags)
624 hostWayTag = case waysTag hostFullWays of
625 "" -> ""
626 tag -> tag ++ "_"
627
628 normalObjectSuffix :: String
629 normalObjectSuffix = phaseInputExt StopLn
630
631 data Way' = Normal | Prof | Dyn
632
633 failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
634 failNonStd dflags srcspan = dieWith dflags srcspan $
635 text "Cannot load" <+> pprWay' compWay <+>
636 text "objects when GHC is built" <+> pprWay' ghciWay $$
637 text "To fix this, either:" $$
638 text " (1) Use -fexternal-interpreter, or" $$
639 buildTwiceMsg
640 where compWay
641 | ways dflags `hasWay` WayDyn = Dyn
642 | ways dflags `hasWay` WayProf = Prof
643 | otherwise = Normal
644 ghciWay
645 | hostIsDynamic = Dyn
646 | hostIsProfiled = Prof
647 | otherwise = Normal
648 buildTwiceMsg = case (ghciWay, compWay) of
649 (Normal, Dyn) -> dynamicTooMsg
650 (Dyn, Normal) -> dynamicTooMsg
651 _ ->
652 text " (2) Build the program twice: once" <+>
653 pprWay' ghciWay <> text ", and then" $$
654 text " " <> pprWay' compWay <+>
655 text "using -osuf to set a different object file suffix."
656 dynamicTooMsg = text " (2) Use -dynamic-too," <+>
657 text "and use -osuf and -dynosuf to set object file suffixes as needed."
658 pprWay' :: Way' -> SDoc
659 pprWay' way = text $ case way of
660 Normal -> "the normal way"
661 Prof -> "with -prof"
662 Dyn -> "with -dynamic"
663
664 getLinkDeps :: HscEnv -> HomePackageTable
665 -> LoaderState
666 -> Maybe FilePath -- replace object suffixes?
667 -> SrcSpan -- for error messages
668 -> [Module] -- If you need these
669 -> IO ([Linkable], [Linkable], [UnitId]) -- ... then link these first
670 -- Fails with an IO exception if it can't find enough files
671
672 getLinkDeps hsc_env hpt pls replace_osuf span mods
673 -- Find all the packages and linkables that a set of modules depends on
674 = do {
675 -- 1. Find the dependent home-pkg-modules/packages from each iface
676 -- (omitting modules from the interactive package, which is already linked)
677 ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)
678 emptyUniqDSet emptyUniqDSet;
679
680 ; let
681 -- 2. Exclude ones already linked
682 -- Main reason: avoid findModule calls in get_linkable
683 (mods_needed, mods_got) = partitionEithers (map split_mods mods_s)
684 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls
685
686 split_mods mod_name =
687 let is_linked = find ((== mod_name) . (moduleName . linkableModule)) (objs_loaded pls ++ bcos_loaded pls)
688 in case is_linked of
689 Just linkable -> Right linkable
690 Nothing -> Left mod_name
691
692 -- 3. For each dependent module, find its linkable
693 -- This will either be in the HPT or (in the case of one-shot
694 -- compilation) we may need to use maybe_getFileLinkable
695 ; let { osuf = objectSuf dflags }
696 ; lnks_needed <- mapM (get_linkable osuf) mods_needed
697
698 ; return (lnks_needed, mods_got ++ lnks_needed, pkgs_needed) }
699 where
700 dflags = hsc_dflags hsc_env
701
702 -- The ModIface contains the transitive closure of the module dependencies
703 -- within the current package, *except* for boot modules: if we encounter
704 -- a boot module, we have to find its real interface and discover the
705 -- dependencies of that. Hence we need to traverse the dependency
706 -- tree recursively. See bug #936, testcase ghci/prog007.
707 follow_deps :: [Module] -- modules to follow
708 -> UniqDSet ModuleName -- accum. module dependencies
709 -> UniqDSet UnitId -- accum. package dependencies
710 -> IO ([ModuleName], [UnitId]) -- result
711 follow_deps [] acc_mods acc_pkgs
712 = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)
713 follow_deps (mod:mods) acc_mods acc_pkgs
714 = do
715 mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $
716 loadInterface msg mod (ImportByUser NotBoot)
717 iface <- case mb_iface of
718 Maybes.Failed err -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))
719 Maybes.Succeeded iface -> return iface
720
721 when (mi_boot iface == IsBoot) $ link_boot_mod_error mod
722
723 let
724 pkg = moduleUnit mod
725 deps = mi_deps iface
726 home_unit = hsc_home_unit hsc_env
727
728 pkg_deps = dep_direct_pkgs deps
729 (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $
730 \case
731 GWIB m IsBoot -> Left m
732 GWIB m NotBoot -> Right m
733
734 mod_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) (boot_deps ++ mod_deps)
735 acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps)
736 acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps)
737 --
738 if not (isHomeUnit home_unit pkg)
739 then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))
740 else follow_deps (map (mkHomeModule home_unit) mod_deps' ++ mods)
741 acc_mods' acc_pkgs'
742 where
743 msg = text "need to link module" <+> ppr mod <+>
744 text "due to use of Template Haskell"
745
746
747 link_boot_mod_error mod =
748 throwGhcExceptionIO (ProgramError (showSDoc dflags (
749 text "module" <+> ppr mod <+>
750 text "cannot be linked; it is only available as a boot module")))
751
752 no_obj :: Outputable a => a -> IO b
753 no_obj mod = dieWith dflags span $
754 text "cannot find object file for module " <>
755 quotes (ppr mod) $$
756 while_linking_expr
757
758 while_linking_expr = text "while linking an interpreted expression"
759
760 -- This one is a build-system bug
761
762 get_linkable osuf mod_name -- A home-package module
763 | Just mod_info <- lookupHpt hpt mod_name
764 = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
765 | otherwise
766 = do -- It's not in the HPT because we are in one shot mode,
767 -- so use the Finder to get a ModLocation...
768 let fc = hsc_FC hsc_env
769 let home_unit = hsc_home_unit hsc_env
770 let dflags = hsc_dflags hsc_env
771 let fopts = initFinderOpts dflags
772 mb_stuff <- findHomeModule fc fopts home_unit mod_name
773 case mb_stuff of
774 Found loc mod -> found loc mod
775 _ -> no_obj mod_name
776 where
777 found loc mod = do {
778 -- ...and then find the linkable for it
779 mb_lnk <- findObjectLinkableMaybe mod loc ;
780 case mb_lnk of {
781 Nothing -> no_obj mod ;
782 Just lnk -> adjust_linkable lnk
783 }}
784
785 adjust_linkable lnk
786 | Just new_osuf <- replace_osuf = do
787 new_uls <- mapM (adjust_ul new_osuf)
788 (linkableUnlinked lnk)
789 return lnk{ linkableUnlinked=new_uls }
790 | otherwise =
791 return lnk
792
793 adjust_ul new_osuf (DotO file) = do
794 massert (osuf `isSuffixOf` file)
795 let file_base = fromJust (stripExtension osuf file)
796 new_file = file_base <.> new_osuf
797 ok <- doesFileExist new_file
798 if (not ok)
799 then dieWith dflags span $
800 text "cannot find object file "
801 <> quotes (text new_file) $$ while_linking_expr
802 else return (DotO new_file)
803 adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
804 adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
805 adjust_ul _ l@(BCOs {}) = return l
806
807
808
809 {- **********************************************************************
810
811 Loading a Decls statement
812
813 ********************************************************************* -}
814
815 loadDecls :: Interp -> HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CompiledByteCode -> IO [(Name, ForeignHValue)]
816 loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do
817 -- Initialise the linker (if it's not been done already)
818 initLoaderState interp hsc_env
819
820 -- Take lock for the actual work.
821 modifyLoaderState interp $ \pls0 -> do
822 -- Link the packages and modules required
823 (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods
824 if failed ok
825 then throwGhcExceptionIO (ProgramError "")
826 else do
827 -- Link the expression itself
828 let ie = plusNameEnv (itbl_env pls) bc_itbls
829 ce = closure_env pls
830
831 -- Link the necessary packages and linkables
832 bco_opts <- initBCOOpts (hsc_dflags hsc_env)
833 new_bindings <- linkSomeBCOs bco_opts interp ie ce [cbc]
834 nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings
835 let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
836 , itbl_env = ie }
837 return (pls2, nms_fhvs)
838 where
839 free_names = uniqDSetToList $
840 foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos
841
842 needed_mods :: [Module]
843 needed_mods = [ nameModule n | n <- free_names,
844 isExternalName n, -- Names from other modules
845 not (isWiredInName n) -- Exclude wired-in names
846 ] -- (see note below)
847 -- Exclude wired-in names because we may not have read
848 -- their interface files, so getLinkDeps will fail
849 -- All wired-in names are in the base package, which we link
850 -- by default, so we can safely ignore them here.
851
852 {- **********************************************************************
853
854 Loading a single module
855
856 ********************************************************************* -}
857
858 loadModule :: Interp -> HscEnv -> Maybe ModuleNameWithIsBoot -> Module -> IO ()
859 loadModule interp hsc_env mnwib mod = do
860 initLoaderState interp hsc_env
861 modifyLoaderState_ interp $ \pls -> do
862 (pls', ok) <- loadDependencies interp hsc_env pls (noSrcSpan, mnwib) [mod]
863 if failed ok
864 then throwGhcExceptionIO (ProgramError "could not load module")
865 else return pls'
866
867 {- **********************************************************************
868
869 Link some linkables
870 The linkables may consist of a mixture of
871 byte-code modules and object modules
872
873 ********************************************************************* -}
874
875 loadModules :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag)
876 loadModules interp hsc_env pls linkables
877 = mask_ $ do -- don't want to be interrupted by ^C in here
878
879 let (objs, bcos) = partition isObjectLinkable
880 (concatMap partitionLinkable linkables)
881 bco_opts <- initBCOOpts (hsc_dflags hsc_env)
882
883 -- Load objects first; they can't depend on BCOs
884 (pls1, ok_flag) <- loadObjects interp hsc_env pls objs
885
886 if failed ok_flag then
887 return (pls1, Failed)
888 else do
889 pls2 <- dynLinkBCOs bco_opts interp pls1 bcos
890 return (pls2, Succeeded)
891
892
893 -- HACK to support f-x-dynamic in the interpreter; no other purpose
894 partitionLinkable :: Linkable -> [Linkable]
895 partitionLinkable li
896 = let li_uls = linkableUnlinked li
897 li_uls_obj = filter isObject li_uls
898 li_uls_bco = filter isInterpretable li_uls
899 in
900 case (li_uls_obj, li_uls_bco) of
901 (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
902 li {linkableUnlinked=li_uls_bco}]
903 _ -> [li]
904
905 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
906 findModuleLinkable_maybe lis mod
907 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
908 [] -> Nothing
909 [li] -> Just li
910 _ -> pprPanic "findModuleLinkable" (ppr mod)
911
912 linkableInSet :: Linkable -> [Linkable] -> Bool
913 linkableInSet l objs_loaded =
914 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
915 Nothing -> False
916 Just m -> linkableTime l == linkableTime m
917
918
919 {- **********************************************************************
920
921 The object-code linker
922
923 ********************************************************************* -}
924
925 -- | Load the object files and link them
926 --
927 -- If the interpreter uses dynamic-linking, build a shared library and load it.
928 -- Otherwise, use the RTS linker.
929 loadObjects
930 :: Interp
931 -> HscEnv
932 -> LoaderState
933 -> [Linkable]
934 -> IO (LoaderState, SuccessFlag)
935 loadObjects interp hsc_env pls objs = do
936 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
937 pls1 = pls { objs_loaded = objs_loaded' }
938 unlinkeds = concatMap linkableUnlinked new_objs
939 wanted_objs = map nameOfObject unlinkeds
940
941 if interpreterDynamic interp
942 then do pls2 <- dynLoadObjs interp hsc_env pls1 wanted_objs
943 return (pls2, Succeeded)
944 else do mapM_ (loadObj interp) wanted_objs
945
946 -- Link them all together
947 ok <- resolveObjs interp
948
949 -- If resolving failed, unload all our
950 -- object modules and carry on
951 if succeeded ok then
952 return (pls1, Succeeded)
953 else do
954 pls2 <- unload_wkr interp [] pls1
955 return (pls2, Failed)
956
957
958 -- | Create a shared library containing the given object files and load it.
959 dynLoadObjs :: Interp -> HscEnv -> LoaderState -> [FilePath] -> IO LoaderState
960 dynLoadObjs _ _ pls [] = return pls
961 dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do
962 let unit_env = hsc_unit_env hsc_env
963 let dflags = hsc_dflags hsc_env
964 let logger = hsc_logger hsc_env
965 let tmpfs = hsc_tmpfs hsc_env
966 let platform = ue_platform unit_env
967 let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]
968 let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]
969 (soFile, libPath , libName) <-
970 newTempLibName logger tmpfs (tmpDir dflags) TFL_CurrentModule (platformSOExt platform)
971 let
972 dflags2 = dflags {
973 -- We don't want the original ldInputs in
974 -- (they're already linked in), but we do want
975 -- to link against previous dynLoadObjs
976 -- libraries if there were any, so that the linker
977 -- can resolve dependencies when it loads this
978 -- library.
979 ldInputs =
980 concatMap (\l -> [ Option ("-l" ++ l) ])
981 (nub $ snd <$> temp_sos)
982 ++ concatMap (\lp -> Option ("-L" ++ lp)
983 : if useXLinkerRPath dflags (platformOS platform)
984 then [ Option "-Xlinker"
985 , Option "-rpath"
986 , Option "-Xlinker"
987 , Option lp ]
988 else [])
989 (nub $ fst <$> temp_sos)
990 ++ concatMap
991 (\lp -> Option ("-L" ++ lp)
992 : if useXLinkerRPath dflags (platformOS platform)
993 then [ Option "-Xlinker"
994 , Option "-rpath"
995 , Option "-Xlinker"
996 , Option lp ]
997 else [])
998 minus_big_ls
999 -- See Note [-Xlinker -rpath vs -Wl,-rpath]
1000 ++ map (\l -> Option ("-l" ++ l)) minus_ls,
1001 -- Add -l options and -L options from dflags.
1002 --
1003 -- When running TH for a non-dynamic way, we still
1004 -- need to make -l flags to link against the dynamic
1005 -- libraries, so we need to add WayDyn to ways.
1006 --
1007 -- Even if we're e.g. profiling, we still want
1008 -- the vanilla dynamic libraries, so we set the
1009 -- ways / build tag to be just WayDyn.
1010 targetWays_ = Set.singleton WayDyn,
1011 outputFile_ = Just soFile
1012 }
1013 -- link all "loaded packages" so symbols in those can be resolved
1014 -- Note: We are loading packages with local scope, so to see the
1015 -- symbols in this link we must link all loaded packages again.
1016 linkDynLib logger tmpfs dflags2 unit_env objs pkgs_loaded
1017
1018 -- if we got this far, extend the lifetime of the library file
1019 changeTempFilesLifetime tmpfs TFL_GhcSession [soFile]
1020 m <- loadDLL interp soFile
1021 case m of
1022 Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
1023 Just err -> linkFail msg err
1024 where
1025 msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed"
1026
1027 rmDupLinkables :: [Linkable] -- Already loaded
1028 -> [Linkable] -- New linkables
1029 -> ([Linkable], -- New loaded set (including new ones)
1030 [Linkable]) -- New linkables (excluding dups)
1031 rmDupLinkables already ls
1032 = go already [] ls
1033 where
1034 go already extras [] = (already, extras)
1035 go already extras (l:ls)
1036 | linkableInSet l already = go already extras ls
1037 | otherwise = go (l:already) (l:extras) ls
1038
1039 {- **********************************************************************
1040
1041 The byte-code linker
1042
1043 ********************************************************************* -}
1044
1045
1046 dynLinkBCOs :: BCOOpts -> Interp -> LoaderState -> [Linkable] -> IO LoaderState
1047 dynLinkBCOs bco_opts interp pls bcos = do
1048
1049 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
1050 pls1 = pls { bcos_loaded = bcos_loaded' }
1051 unlinkeds :: [Unlinked]
1052 unlinkeds = concatMap linkableUnlinked new_bcos
1053
1054 cbcs :: [CompiledByteCode]
1055 cbcs = map byteCodeOfObject unlinkeds
1056
1057
1058 ies = map bc_itbls cbcs
1059 gce = closure_env pls
1060 final_ie = foldr plusNameEnv (itbl_env pls) ies
1061
1062 names_and_refs <- linkSomeBCOs bco_opts interp final_ie gce cbcs
1063
1064 -- We only want to add the external ones to the ClosureEnv
1065 let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
1066
1067 -- Immediately release any HValueRefs we're not going to add
1068 freeHValueRefs interp (map snd to_drop)
1069 -- Wrap finalizers on the ones we want to keep
1070 new_binds <- makeForeignNamedHValueRefs interp to_add
1071
1072 return pls1 { closure_env = extendClosureEnv gce new_binds,
1073 itbl_env = final_ie }
1074
1075 -- Link a bunch of BCOs and return references to their values
1076 linkSomeBCOs :: BCOOpts
1077 -> Interp
1078 -> ItblEnv
1079 -> ClosureEnv
1080 -> [CompiledByteCode]
1081 -> IO [(Name,HValueRef)]
1082 -- The returned HValueRefs are associated 1-1 with
1083 -- the incoming unlinked BCOs. Each gives the
1084 -- value of the corresponding unlinked BCO
1085
1086 linkSomeBCOs bco_opts interp ie ce mods = foldr fun do_link mods []
1087 where
1088 fun CompiledByteCode{..} inner accum =
1089 case bc_breaks of
1090 Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum)
1091 Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray ->
1092 inner ((breakarray, bc_bcos) : accum)
1093
1094 do_link [] = return []
1095 do_link mods = do
1096 let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ]
1097 names = map (unlinkedBCOName . snd) flat
1098 bco_ix = mkNameEnv (zip names [0..])
1099 resolved <- sequence [ linkBCO interp ie ce bco_ix breakarray bco
1100 | (breakarray, bco) <- flat ]
1101 hvrefs <- createBCOs interp bco_opts resolved
1102 return (zip names hvrefs)
1103
1104 -- | Useful to apply to the result of 'linkSomeBCOs'
1105 makeForeignNamedHValueRefs
1106 :: Interp -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)]
1107 makeForeignNamedHValueRefs interp bindings =
1108 mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue interp hvref) bindings
1109
1110 {- **********************************************************************
1111
1112 Unload some object modules
1113
1114 ********************************************************************* -}
1115
1116 -- ---------------------------------------------------------------------------
1117 -- | Unloading old objects ready for a new compilation sweep.
1118 --
1119 -- The compilation manager provides us with a list of linkables that it
1120 -- considers \"stable\", i.e. won't be recompiled this time around. For
1121 -- each of the modules current linked in memory,
1122 --
1123 -- * if the linkable is stable (and it's the same one -- the user may have
1124 -- recompiled the module on the side), we keep it,
1125 --
1126 -- * otherwise, we unload it.
1127 --
1128 -- * we also implicitly unload all temporary bindings at this point.
1129 --
1130 unload
1131 :: Interp
1132 -> HscEnv
1133 -> [Linkable] -- ^ The linkables to *keep*.
1134 -> IO ()
1135 unload interp hsc_env linkables
1136 = mask_ $ do -- mask, so we're safe from Ctrl-C in here
1137
1138 -- Initialise the linker (if it's not been done already)
1139 initLoaderState interp hsc_env
1140
1141 new_pls
1142 <- modifyLoaderState interp $ \pls -> do
1143 pls1 <- unload_wkr interp linkables pls
1144 return (pls1, pls1)
1145
1146 let logger = hsc_logger hsc_env
1147 debugTraceMsg logger 3 $
1148 text "unload: retaining objs" <+> ppr (objs_loaded new_pls)
1149 debugTraceMsg logger 3 $
1150 text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)
1151 return ()
1152
1153 unload_wkr
1154 :: Interp
1155 -> [Linkable] -- stable linkables
1156 -> LoaderState
1157 -> IO LoaderState
1158 -- Does the core unload business
1159 -- (the wrapper blocks exceptions and deals with the LS get and put)
1160
1161 unload_wkr interp keep_linkables pls@LoaderState{..} = do
1162 -- NB. careful strictness here to avoid keeping the old LS when
1163 -- we're unloading some code. -fghci-leak-check with the tests in
1164 -- testsuite/ghci can detect space leaks here.
1165
1166 let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables
1167
1168 discard keep l = not (linkableInSet l keep)
1169
1170 (objs_to_unload, remaining_objs_loaded) =
1171 partition (discard objs_to_keep) objs_loaded
1172 (bcos_to_unload, remaining_bcos_loaded) =
1173 partition (discard bcos_to_keep) bcos_loaded
1174
1175 mapM_ unloadObjs objs_to_unload
1176 mapM_ unloadObjs bcos_to_unload
1177
1178 -- If we unloaded any object files at all, we need to purge the cache
1179 -- of lookupSymbol results.
1180 when (not (null (objs_to_unload ++
1181 filter (not . null . linkableObjs) bcos_to_unload))) $
1182 purgeLookupSymbolCache interp
1183
1184 let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded
1185
1186 -- Note that we want to remove all *local*
1187 -- (i.e. non-isExternal) names too (these are the
1188 -- temporary bindings from the command line).
1189 keep_name :: (Name, a) -> Bool
1190 keep_name (n,_) = isExternalName n &&
1191 nameModule n `elemModuleSet` bcos_retained
1192
1193 itbl_env' = filterNameEnv keep_name itbl_env
1194 closure_env' = filterNameEnv keep_name closure_env
1195
1196 !new_pls = pls { itbl_env = itbl_env',
1197 closure_env = closure_env',
1198 bcos_loaded = remaining_bcos_loaded,
1199 objs_loaded = remaining_objs_loaded }
1200
1201 return new_pls
1202 where
1203 unloadObjs :: Linkable -> IO ()
1204 unloadObjs lnk
1205 | interpreterDynamic interp = return ()
1206 -- We don't do any cleanup when linking objects with the
1207 -- dynamic linker. Doing so introduces extra complexity for
1208 -- not much benefit.
1209
1210 | otherwise
1211 = mapM_ (unloadObj interp) [f | DotO f <- linkableUnlinked lnk]
1212 -- The components of a BCO linkable may contain
1213 -- dot-o files. Which is very confusing.
1214 --
1215 -- But the BCO parts can be unlinked just by
1216 -- letting go of them (plus of course depopulating
1217 -- the symbol table which is done in the main body)
1218
1219 -- If this package is already part of the GHCi binary, we'll already
1220 -- have the right DLLs for this package loaded, so don't try to
1221 -- load them again.
1222 --
1223 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
1224 -- as far as the loader is concerned, but it does initialise the list
1225 -- of DLL handles that rts/Linker.c maintains, and that in turn is
1226 -- used by lookupSymbol. So we must call addDLL for each library
1227 -- just to get the DLL handle into the list.
1228 partOfGHCi :: [PackageName]
1229 partOfGHCi
1230 | isWindowsHost || isDarwinHost = []
1231 | otherwise = map (PackageName . mkFastString)
1232 ["base", "template-haskell", "editline"]
1233
1234 showLS :: LibrarySpec -> String
1235 showLS (Objects nms) = "(static) [" ++ intercalate ", " nms ++ "]"
1236 showLS (Archive nm) = "(static archive) " ++ nm
1237 showLS (DLL nm) = "(dynamic) " ++ nm
1238 showLS (DLLPath nm) = "(dynamic) " ++ nm
1239 showLS (Framework nm) = "(framework) " ++ nm
1240
1241 -- | Load exactly the specified packages, and their dependents (unless of
1242 -- course they are already loaded). The dependents are loaded
1243 -- automatically, and it doesn't matter what order you specify the input
1244 -- packages.
1245 --
1246 loadPackages :: Interp -> HscEnv -> [UnitId] -> IO ()
1247 -- NOTE: in fact, since each module tracks all the packages it depends on,
1248 -- we don't really need to use the package-config dependencies.
1249 --
1250 -- However we do need the package-config stuff (to find aux libs etc),
1251 -- and following them lets us load libraries in the right order, which
1252 -- perhaps makes the error message a bit more localised if we get a link
1253 -- failure. So the dependency walking code is still here.
1254
1255 loadPackages interp hsc_env new_pkgs = do
1256 -- It's probably not safe to try to load packages concurrently, so we take
1257 -- a lock.
1258 initLoaderState interp hsc_env
1259 modifyLoaderState_ interp $ \pls ->
1260 loadPackages' interp hsc_env new_pkgs pls
1261
1262 loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState
1263 loadPackages' interp hsc_env new_pks pls = do
1264 (pkgs', hs_objs, non_hs_objs) <- link (pkgs_loaded pls) new_pks
1265 return $! pls { pkgs_loaded = pkgs'
1266 , hs_objs_loaded = hs_objs ++ hs_objs_loaded pls
1267 , non_hs_objs_loaded = non_hs_objs ++ non_hs_objs_loaded pls }
1268 where
1269 link :: [UnitId] -> [UnitId] -> IO ([UnitId], [LibrarySpec], [LibrarySpec])
1270 link pkgs new_pkgs =
1271 foldM link_one (pkgs, [],[]) new_pkgs
1272
1273 link_one (pkgs, acc_hs, acc_non_hs) new_pkg
1274 | new_pkg `elem` pkgs -- Already linked
1275 = return (pkgs, acc_hs, acc_non_hs)
1276
1277 | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg
1278 = do { -- Link dependents first
1279 (pkgs', hs_cls', extra_cls') <- link pkgs (unitDepends pkg_cfg)
1280 -- Now link the package itself
1281 ; (hs_cls, extra_cls) <- loadPackage interp hsc_env pkg_cfg
1282 ; return (new_pkg : pkgs', acc_hs ++ hs_cls ++ hs_cls', acc_non_hs ++ extra_cls ++ extra_cls') }
1283
1284 | otherwise
1285 = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))
1286
1287
1288 loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec])
1289 loadPackage interp hsc_env pkg
1290 = do
1291 let dflags = hsc_dflags hsc_env
1292 let logger = hsc_logger hsc_env
1293 platform = targetPlatform dflags
1294 is_dyn = interpreterDynamic interp
1295 dirs | is_dyn = map ST.unpack $ Packages.unitLibraryDynDirs pkg
1296 | otherwise = map ST.unpack $ Packages.unitLibraryDirs pkg
1297
1298 let hs_libs = map ST.unpack $ Packages.unitLibraries pkg
1299 -- The FFI GHCi import lib isn't needed as
1300 -- GHC.Linker.Loader + rts/Linker.c link the
1301 -- interpreted references to FFI to the compiled FFI.
1302 -- We therefore filter it out so that we don't get
1303 -- duplicate symbol errors.
1304 hs_libs' = filter ("HSffi" /=) hs_libs
1305
1306 -- Because of slight differences between the GHC dynamic linker and
1307 -- the native system linker some packages have to link with a
1308 -- different list of libraries when using GHCi. Examples include: libs
1309 -- that are actually gnu ld scripts, and the possibility that the .a
1310 -- libs do not exactly match the .so/.dll equivalents. So if the
1311 -- package file provides an "extra-ghci-libraries" field then we use
1312 -- that instead of the "extra-libraries" field.
1313 extdeplibs = map ST.unpack (if null (Packages.unitExtDepLibsGhc pkg)
1314 then Packages.unitExtDepLibsSys pkg
1315 else Packages.unitExtDepLibsGhc pkg)
1316 linkerlibs = [ lib | '-':'l':lib <- (map ST.unpack $ Packages.unitLinkerOptions pkg) ]
1317 extra_libs = extdeplibs ++ linkerlibs
1318
1319 -- See Note [Fork/Exec Windows]
1320 gcc_paths <- getGCCPaths logger dflags (platformOS platform)
1321 dirs_env <- addEnvPaths "LIBRARY_PATH" dirs
1322
1323 hs_classifieds
1324 <- mapM (locateLib interp hsc_env True dirs_env gcc_paths) hs_libs'
1325 extra_classifieds
1326 <- mapM (locateLib interp hsc_env False dirs_env gcc_paths) extra_libs
1327 let classifieds = hs_classifieds ++ extra_classifieds
1328
1329 -- Complication: all the .so's must be loaded before any of the .o's.
1330 let known_dlls = [ dll | DLLPath dll <- classifieds ]
1331 dlls = [ dll | DLL dll <- classifieds ]
1332 objs = [ obj | Objects objs <- classifieds
1333 , obj <- objs ]
1334 archs = [ arch | Archive arch <- classifieds ]
1335
1336 -- Add directories to library search paths
1337 let dll_paths = map takeDirectory known_dlls
1338 all_paths = nub $ map normalise $ dll_paths ++ dirs
1339 all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
1340 pathCache <- mapM (addLibrarySearchPath interp) all_paths_env
1341
1342 maybePutSDoc logger
1343 (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ")
1344
1345 -- See comments with partOfGHCi
1346 #if defined(CAN_LOAD_DLL)
1347 when (unitPackageName pkg `notElem` partOfGHCi) $ do
1348 loadFrameworks interp platform pkg
1349 -- See Note [Crash early load_dyn and locateLib]
1350 -- Crash early if can't load any of `known_dlls`
1351 mapM_ (load_dyn interp hsc_env True) known_dlls
1352 -- For remaining `dlls` crash early only when there is surely
1353 -- no package's DLL around ... (not is_dyn)
1354 mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls
1355 #endif
1356 -- After loading all the DLLs, we can load the static objects.
1357 -- Ordering isn't important here, because we do one final link
1358 -- step to resolve everything.
1359 mapM_ (loadObj interp) objs
1360 mapM_ (loadArchive interp) archs
1361
1362 maybePutStr logger "linking ... "
1363 ok <- resolveObjs interp
1364
1365 -- DLLs are loaded, reset the search paths
1366 -- Import libraries will be loaded via loadArchive so only
1367 -- reset the DLL search path after all archives are loaded
1368 -- as well.
1369 mapM_ (removeLibrarySearchPath interp) $ reverse pathCache
1370
1371 if succeeded ok
1372 then do
1373 maybePutStrLn logger "done."
1374 return (hs_classifieds, extra_classifieds)
1375 else let errmsg = text "unable to load unit `"
1376 <> pprUnitInfoForUser pkg <> text "'"
1377 in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg))
1378
1379 {-
1380 Note [Crash early load_dyn and locateLib]
1381 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1382 If a package is "normal" (exposes it's code from more than zero Haskell
1383 modules, unlike e.g. that in ghcilink004) and is built "dyn" way, then
1384 it has it's code compiled and linked into the DLL, which GHCi linker picks
1385 when loading the package's code (see the big comment in the beginning of
1386 `locateLib`).
1387
1388 When loading DLLs, GHCi linker simply calls the system's `dlopen` or
1389 `LoadLibrary` APIs. This is quite different from the case when GHCi linker
1390 loads an object file or static library. When loading an object file or static
1391 library GHCi linker parses them and resolves all symbols "manually".
1392 These object file or static library may reference some external symbols
1393 defined in some external DLLs. And GHCi should know which these
1394 external DLLs are.
1395
1396 But when GHCi loads a DLL, it's the *system* linker who manages all
1397 the necessary dependencies, and it is able to load this DLL not having
1398 any extra info. Thus we don't *have to* crash in this case even if we
1399 are unable to load any supposed dependencies explicitly.
1400
1401 Suppose during GHCi session a client of the package wants to
1402 `foreign import` a symbol which isn't exposed by the package DLL, but
1403 is exposed by such an external (dependency) DLL.
1404 If the DLL isn't *explicitly* loaded because `load_dyn` failed to do
1405 this, then the client code eventually crashes because the GHCi linker
1406 isn't able to locate this symbol (GHCi linker maintains a list of
1407 explicitly loaded DLLs it looks into when trying to find a symbol).
1408
1409 This is why we still should try to load all the dependency DLLs
1410 even though we know that the system linker loads them implicitly when
1411 loading the package DLL.
1412
1413 Why we still keep the `crash_early` opportunity then not allowing such
1414 a permissive behaviour for any DLLs? Well, we, perhaps, improve a user
1415 experience in some cases slightly.
1416
1417 But if it happens there exist other corner cases where our current
1418 usage of `crash_early` flag is overly restrictive, we may lift the
1419 restriction very easily.
1420 -}
1421
1422 -- we have already searched the filesystem; the strings passed to load_dyn
1423 -- can be passed directly to loadDLL. They are either fully-qualified
1424 -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case,
1425 -- loadDLL is going to search the system paths to find the library.
1426 load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO ()
1427 load_dyn interp hsc_env crash_early dll = do
1428 r <- loadDLL interp dll
1429 case r of
1430 Nothing -> return ()
1431 Just err ->
1432 if crash_early
1433 then cmdLineErrorIO err
1434 else
1435 when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts)
1436 $ logMsg logger
1437 (mkMCDiagnostic diag_opts $ WarningWithFlag Opt_WarnMissedExtraSharedLib)
1438 noSrcSpan $ withPprStyle defaultUserStyle (note err)
1439 where
1440 diag_opts = initDiagOpts (hsc_dflags hsc_env)
1441 logger = hsc_logger hsc_env
1442 note err = vcat $ map text
1443 [ err
1444 , "It's OK if you don't want to use symbols from it directly."
1445 , "(the package DLL is loaded by the system linker"
1446 , " which manages dependencies by itself)." ]
1447
1448 loadFrameworks :: Interp -> Platform -> UnitInfo -> IO ()
1449 loadFrameworks interp platform pkg
1450 = when (platformUsesFrameworks platform) $ mapM_ load frameworks
1451 where
1452 fw_dirs = map ST.unpack $ Packages.unitExtDepFrameworkDirs pkg
1453 frameworks = map ST.unpack $ Packages.unitExtDepFrameworks pkg
1454
1455 load fw = do r <- loadFramework interp fw_dirs fw
1456 case r of
1457 Nothing -> return ()
1458 Just err -> cmdLineErrorIO ("can't load framework: "
1459 ++ fw ++ " (" ++ err ++ ")" )
1460
1461 -- Try to find an object file for a given library in the given paths.
1462 -- If it isn't present, we assume that addDLL in the RTS can find it,
1463 -- which generally means that it should be a dynamic library in the
1464 -- standard system search path.
1465 -- For GHCi we tend to prefer dynamic libraries over static ones as
1466 -- they are easier to load and manage, have less overhead.
1467 locateLib
1468 :: Interp
1469 -> HscEnv
1470 -> Bool
1471 -> [FilePath]
1472 -> [FilePath]
1473 -> String
1474 -> IO LibrarySpec
1475 locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib
1476 | not is_hs
1477 -- For non-Haskell libraries (e.g. gmp, iconv):
1478 -- first look in library-dirs for a dynamic library (on User paths only)
1479 -- (libfoo.so)
1480 -- then try looking for import libraries on Windows (on User paths only)
1481 -- (.dll.a, .lib)
1482 -- first look in library-dirs for a dynamic library (on GCC paths only)
1483 -- (libfoo.so)
1484 -- then check for system dynamic libraries (e.g. kernel32.dll on windows)
1485 -- then try looking for import libraries on Windows (on GCC paths only)
1486 -- (.dll.a, .lib)
1487 -- then look in library-dirs for a static library (libfoo.a)
1488 -- then look in library-dirs and inplace GCC for a dynamic library (libfoo.so)
1489 -- then try looking for import libraries on Windows (.dll.a, .lib)
1490 -- then look in library-dirs and inplace GCC for a static library (libfoo.a)
1491 -- then try "gcc --print-file-name" to search gcc's search path
1492 -- for a dynamic library (#5289)
1493 -- otherwise, assume loadDLL can find it
1494 --
1495 -- The logic is a bit complicated, but the rationale behind it is that
1496 -- loading a shared library for us is O(1) while loading an archive is
1497 -- O(n). Loading an import library is also O(n) so in general we prefer
1498 -- shared libraries because they are simpler and faster.
1499 --
1500 =
1501 #if defined(CAN_LOAD_DLL)
1502 findDll user `orElse`
1503 #endif
1504 tryImpLib user `orElse`
1505 #if defined(CAN_LOAD_DLL)
1506 findDll gcc `orElse`
1507 findSysDll `orElse`
1508 #endif
1509 tryImpLib gcc `orElse`
1510 findArchive `orElse`
1511 tryGcc `orElse`
1512 assumeDll
1513
1514 | loading_dynamic_hs_libs -- search for .so libraries first.
1515 = findHSDll `orElse`
1516 findDynObject `orElse`
1517 assumeDll
1518
1519 | otherwise
1520 -- use HSfoo.{o,p_o} if it exists, otherwise fallback to libHSfoo{,_p}.a
1521 = findObject `orElse`
1522 findArchive `orElse`
1523 assumeDll
1524
1525 where
1526 dflags = hsc_dflags hsc_env
1527 logger = hsc_logger hsc_env
1528 diag_opts = initDiagOpts dflags
1529 dirs = lib_dirs ++ gcc_dirs
1530 gcc = False
1531 user = True
1532
1533 obj_file
1534 | is_hs && loading_profiled_hs_libs = lib <.> "p_o"
1535 | otherwise = lib <.> "o"
1536 dyn_obj_file = lib <.> "dyn_o"
1537 arch_files = [ "lib" ++ lib ++ lib_tag <.> "a"
1538 , lib <.> "a" -- native code has no lib_tag
1539 , "lib" ++ lib, lib
1540 ]
1541 lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""
1542
1543 loading_profiled_hs_libs = interpreterProfiled interp
1544 loading_dynamic_hs_libs = interpreterDynamic interp
1545
1546 import_libs = [ lib <.> "lib" , "lib" ++ lib <.> "lib"
1547 , "lib" ++ lib <.> "dll.a", lib <.> "dll.a"
1548 ]
1549
1550 hs_dyn_lib_name = lib ++ dynLibSuffix (ghcNameVersion dflags)
1551 hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name
1552
1553 so_name = platformSOName platform lib
1554 lib_so_name = "lib" ++ so_name
1555 dyn_lib_file = case (arch, os) of
1556 (ArchX86_64, OSSolaris2) -> "64" </> so_name
1557 _ -> so_name
1558
1559 findObject = liftM (fmap $ Objects . (:[])) $ findFile dirs obj_file
1560 findDynObject = liftM (fmap $ Objects . (:[])) $ findFile dirs dyn_obj_file
1561 findArchive = let local name = liftM (fmap Archive) $ findFile dirs name
1562 in apply (map local arch_files)
1563 findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file
1564 findDll re = let dirs' = if re == user then lib_dirs else gcc_dirs
1565 in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file
1566 findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $
1567 findSystemLibrary interp so_name
1568 tryGcc = let search = searchForLibUsingGcc logger dflags
1569 dllpath = liftM (fmap DLLPath)
1570 short = dllpath $ search so_name lib_dirs
1571 full = dllpath $ search lib_so_name lib_dirs
1572 gcc name = liftM (fmap Archive) $ search name lib_dirs
1573 files = import_libs ++ arch_files
1574 dlls = [short, full]
1575 archives = map gcc files
1576 in apply $
1577 #if defined(CAN_LOAD_DLL)
1578 dlls ++
1579 #endif
1580 archives
1581 tryImpLib re = case os of
1582 OSMinGW32 ->
1583 let dirs' = if re == user then lib_dirs else gcc_dirs
1584 implib name = liftM (fmap Archive) $
1585 findFile dirs' name
1586 in apply (map implib import_libs)
1587 _ -> return Nothing
1588
1589 -- TH Makes use of the interpreter so this failure is not obvious.
1590 -- So we are nice and warn/inform users why we fail before we do.
1591 -- But only for haskell libraries, as C libraries don't have a
1592 -- profiling/non-profiling distinction to begin with.
1593 assumeDll
1594 | is_hs
1595 , not loading_dynamic_hs_libs
1596 , interpreterProfiled interp
1597 = do
1598 let diag = mkMCDiagnostic diag_opts WarningWithoutFlag
1599 logMsg logger diag noSrcSpan $ withPprStyle defaultErrStyle $
1600 text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$
1601 text " \tTrying dynamic library instead. If this fails try to rebuild" <+>
1602 text "libraries with profiling support."
1603 return (DLL lib)
1604 | otherwise = return (DLL lib)
1605 infixr `orElse`
1606 f `orElse` g = f >>= maybe g return
1607
1608 apply :: [IO (Maybe a)] -> IO (Maybe a)
1609 apply [] = return Nothing
1610 apply (x:xs) = do x' <- x
1611 if isJust x'
1612 then return x'
1613 else apply xs
1614
1615 platform = targetPlatform dflags
1616 arch = platformArch platform
1617 os = platformOS platform
1618
1619 searchForLibUsingGcc :: Logger -> DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)
1620 searchForLibUsingGcc logger dflags so dirs = do
1621 -- GCC does not seem to extend the library search path (using -L) when using
1622 -- --print-file-name. So instead pass it a new base location.
1623 str <- askLd logger dflags (map (FileOption "-B") dirs
1624 ++ [Option "--print-file-name", Option so])
1625 let file = case lines str of
1626 [] -> ""
1627 l:_ -> l
1628 if (file == so)
1629 then return Nothing
1630 else do b <- doesFileExist file -- file could be a folder (see #16063)
1631 return (if b then Just file else Nothing)
1632
1633 -- | Retrieve the list of search directory GCC and the System use to find
1634 -- libraries and components. See Note [Fork/Exec Windows].
1635 getGCCPaths :: Logger -> DynFlags -> OS -> IO [FilePath]
1636 getGCCPaths logger dflags os
1637 = case os of
1638 OSMinGW32 ->
1639 do gcc_dirs <- getGccSearchDirectory logger dflags "libraries"
1640 sys_dirs <- getSystemDirectories
1641 return $ nub $ gcc_dirs ++ sys_dirs
1642 _ -> return []
1643
1644 -- | Cache for the GCC search directories as this can't easily change
1645 -- during an invocation of GHC. (Maybe with some env. variable but we'll)
1646 -- deal with that highly unlikely scenario then.
1647 {-# NOINLINE gccSearchDirCache #-}
1648 gccSearchDirCache :: IORef [(String, [String])]
1649 gccSearchDirCache = unsafePerformIO $ newIORef []
1650
1651 -- Note [Fork/Exec Windows]
1652 -- ~~~~~~~~~~~~~~~~~~~~~~~~
1653 -- fork/exec is expensive on Windows, for each time we ask GCC for a library we
1654 -- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1.
1655 -- So instead get a list of location that GCC would search and use findDirs
1656 -- which hopefully is written in an optimized mannor to take advantage of
1657 -- caching. At the very least we remove the overhead of the fork/exec and waits
1658 -- which dominate a large percentage of startup time on Windows.
1659 getGccSearchDirectory :: Logger -> DynFlags -> String -> IO [FilePath]
1660 getGccSearchDirectory logger dflags key = do
1661 cache <- readIORef gccSearchDirCache
1662 case lookup key cache of
1663 Just x -> return x
1664 Nothing -> do
1665 str <- askLd logger dflags [Option "--print-search-dirs"]
1666 let line = dropWhile isSpace str
1667 name = key ++ ": ="
1668 if null line
1669 then return []
1670 else do let val = split $ find name line
1671 dirs <- filterM doesDirectoryExist val
1672 modifyIORef' gccSearchDirCache ((key, dirs):)
1673 return val
1674 where split :: FilePath -> [FilePath]
1675 split r = case break (==';') r of
1676 (s, [] ) -> [s]
1677 (s, (_:xs)) -> s : split xs
1678
1679 find :: String -> String -> String
1680 find r x = let lst = lines x
1681 val = filter (r `isPrefixOf`) lst
1682 in if null val
1683 then []
1684 else case break (=='=') (head val) of
1685 (_ , []) -> []
1686 (_, (_:xs)) -> xs
1687
1688 -- | Get a list of system search directories, this to alleviate pressure on
1689 -- the findSysDll function.
1690 getSystemDirectories :: IO [FilePath]
1691 #if defined(mingw32_HOST_OS)
1692 getSystemDirectories = fmap (:[]) getSystemDirectory
1693 #else
1694 getSystemDirectories = return []
1695 #endif
1696
1697 -- | Merge the given list of paths with those in the environment variable
1698 -- given. If the variable does not exist then just return the identity.
1699 addEnvPaths :: String -> [String] -> IO [String]
1700 addEnvPaths name list
1701 = do -- According to POSIX (chapter 8.3) a zero-length prefix means current
1702 -- working directory. Replace empty strings in the env variable with
1703 -- `working_dir` (see also #14695).
1704 working_dir <- getCurrentDirectory
1705 values <- lookupEnv name
1706 case values of
1707 Nothing -> return list
1708 Just arr -> return $ list ++ splitEnv working_dir arr
1709 where
1710 splitEnv :: FilePath -> String -> [String]
1711 splitEnv working_dir value =
1712 case break (== envListSep) value of
1713 (x, [] ) ->
1714 [if null x then working_dir else x]
1715 (x, (_:xs)) ->
1716 (if null x then working_dir else x) : splitEnv working_dir xs
1717 #if defined(mingw32_HOST_OS)
1718 envListSep = ';'
1719 #else
1720 envListSep = ':'
1721 #endif
1722
1723 -- ----------------------------------------------------------------------------
1724 -- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1725
1726
1727 {- **********************************************************************
1728
1729 Helper functions
1730
1731 ********************************************************************* -}
1732
1733 maybePutSDoc :: Logger -> SDoc -> IO ()
1734 maybePutSDoc logger s
1735 = when (logVerbAtLeast logger 2) $
1736 logMsg logger
1737 MCInteractive
1738 noSrcSpan
1739 $ withPprStyle defaultUserStyle s
1740
1741 maybePutStr :: Logger -> String -> IO ()
1742 maybePutStr logger s = maybePutSDoc logger (text s)
1743
1744 maybePutStrLn :: Logger -> String -> IO ()
1745 maybePutStrLn logger s = maybePutSDoc logger (text s <> text "\n")