1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.98 2001/10/23 11:42:21 simonmar Exp $
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2000
8 -----------------------------------------------------------------------------
10 {-# OPTIONS -#include "Linker.h" #-}
11 {-# OPTIONS -#include "SchedAPI.h" #-}
12 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
14 #include "../includes/config.h"
15 #include "HsVersions.h"
19 import HscTypes ( TyThing(..) )
26 import Finder ( flushPackageCache )
28 import Id ( isRecordSelector, recordSelectorFieldLabel,
29 isDataConWrapId, idName )
30 import Class ( className )
31 import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon )
32 import FieldLabel ( fieldLabelTyCon )
33 import SrcLoc ( isGoodSrcLoc )
34 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
36 import OccName ( isSymOcc )
37 import BasicTypes ( defaultFixity )
39 import CmdLineOpts ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset )
40 import Panic ( GhcException(..) )
43 #ifndef mingw32_TARGET_OS
49 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
65 import PrelGHC ( unsafeCoerce# )
66 import Foreign ( nullPtr )
67 import CString ( peekCString )
69 -----------------------------------------------------------------------------
73 \ / _ \\ /\\ /\\/ __(_)\n\
74 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
75 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
76 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
78 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
80 builtin_commands :: [(String, String -> GHCi Bool)]
82 ("add", keepGoing addModule),
83 ("cd", keepGoing changeDirectory),
84 ("def", keepGoing defineMacro),
85 ("help", keepGoing help),
86 ("?", keepGoing help),
87 ("info", keepGoing info),
88 ("load", keepGoing loadModule),
89 ("module", keepGoing setContext),
90 ("reload", keepGoing reloadModule),
91 ("set", keepGoing setCmd),
92 ("type", keepGoing typeOfExpr),
93 ("unset", keepGoing unsetOptions),
94 ("undef", keepGoing undefineMacro),
98 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
99 keepGoing a str = a str >> return False
101 shortHelpText = "use :? for help.\n"
104 \ Commands available from the prompt:\n\
106 \ <stmt> evaluate/run <stmt>\n\
107 \ :add <filename> ... add module(s) to the current target set\n\
108 \ :cd <dir> change directory to <dir>\n\
109 \ :def <cmd> <expr> define a command :<cmd>\n\
110 \ :help, :? display this list of commands\n\
111 \ :info [<name> ...] display information about the given names\n\
112 \ :load <filename> ... load module(s) and their dependents\n\
113 \ :module <mod> set the context for expression evaluation to <mod>\n\
114 \ :reload reload the current module set\n\
115 \ :set <option> ... set options\n\
116 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
117 \ :set prog <progname> set the value returned by System.getProgName\n\
118 \ :undef <cmd> undefine user-defined command :<cmd>\n\
119 \ :type <expr> show the type of <expr>\n\
120 \ :unset <option> ... unset options\n\
122 \ :!<command> run the shell command <command>\n\
124 \ Options for `:set' and `:unset':\n\
126 \ +r revert top-level expressions after each evaluation\n\
127 \ +s print timing/memory stats after each evaluation\n\
128 \ +t print type after evaluation\n\
129 \ -<flags> most GHC command line flags can also be set here\n\
130 \ (eg. -v2, -fglasgow-exts, etc.)\n\
133 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
134 interactiveUI cmstate paths cmdline_libs = do
136 hSetBuffering stdout NoBuffering
138 -- link in the available packages
139 pkgs <- getPackageInfo
141 linkPackages cmdline_libs pkgs
143 (cmstate, ok, mods) <-
145 [] -> return (cmstate, True, [])
146 _ -> cmLoadModule cmstate paths
148 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
152 dflags <- getDynFlags
154 (cmstate, maybe_hval)
155 <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering >> IO.hSetBuffering IO.stderr IO.NoBuffering"
157 Just hval -> unsafeCoerce# hval :: IO ()
158 _ -> panic "interactiveUI:buffering"
160 (cmstate, maybe_hval)
161 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
163 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
164 _ -> panic "interactiveUI:stderr"
166 (cmstate, maybe_hval)
167 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
169 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
170 _ -> panic "interactiveUI:stdout"
172 startGHCi runGHCi GHCiState{ progname = "<interactive>",
178 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
179 Readline.resetTerminal Nothing
187 read_dot_files <- io (readIORef v_Read_DotGHCi)
189 when (read_dot_files) $ do
192 exists <- io (doesFileExist file)
194 dir_ok <- io (checkPerms ".")
195 file_ok <- io (checkPerms file)
196 when (dir_ok && file_ok) $ do
197 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
200 Right hdl -> fileLoop hdl False
202 when (read_dot_files) $ do
203 -- Read in $HOME/.ghci
204 either_dir <- io (IO.try (getEnv "HOME"))
208 cwd <- io (getCurrentDirectory)
209 when (dir /= cwd) $ do
210 let file = dir ++ "/.ghci"
211 ok <- io (checkPerms file)
213 either_hdl <- io (IO.try (openFile file ReadMode))
216 Right hdl -> fileLoop hdl False
221 io $ do putStrLn "Leaving GHCi."
225 -- ignore ^C exceptions caught here
226 ghciHandleDyn (\e -> case e of Interrupted -> ghciUnblock interactiveLoop
227 _other -> return ()) $ do
228 -- read commands from stdin
229 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
236 -- NOTE: We only read .ghci files if they are owned by the current user,
237 -- and aren't world writable. Otherwise, we could be accidentally
238 -- running code planted by a malicious third party.
240 -- Furthermore, We only read ./.ghci if . is owned by the current user
241 -- and isn't writable by anyone else. I think this is sufficient: we
242 -- don't need to check .. and ../.. etc. because "." always refers to
243 -- the same directory while a process is running.
245 checkPerms :: String -> IO Bool
247 handle (\_ -> return False) $ do
248 #ifdef mingw32_TARGET_OS
251 st <- getFileStatus name
253 if fileOwner st /= me then do
254 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
257 let mode = fileMode st
258 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
259 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
261 putStrLn $ "*** WARNING: " ++ name ++
262 " is writable by someone else, IGNORING!"
267 fileLoop :: Handle -> Bool -> GHCi ()
268 fileLoop hdl prompt = do
270 mod <- io (cmGetContext (cmstate st))
271 when prompt (io (putStr (mod ++ "> ")))
272 l <- io (IO.try (hGetLine hdl))
274 Left e | isEOFError e -> return ()
275 | otherwise -> throw e
277 case remove_spaces l of
278 "" -> fileLoop hdl prompt
279 l -> do quit <- runCommand l
280 if quit then return () else fileLoop hdl prompt
282 stringLoop :: [String] -> GHCi ()
283 stringLoop [] = return ()
284 stringLoop (s:ss) = do
286 case remove_spaces s of
288 l -> do quit <- runCommand l
289 if quit then return () else stringLoop ss
291 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
292 readlineLoop :: GHCi ()
295 mod <- io (cmGetContext (cmstate st))
297 l <- io (readline (mod ++ "> "))
301 case remove_spaces l of
306 if quit then return () else readlineLoop
309 -- Top level exception handler, just prints out the exception
311 runCommand :: String -> GHCi Bool
313 ghciHandle ( \exception -> do
315 showException exception
320 showException (DynException dyn) =
321 case fromDynamic dyn of
323 io (putStrLn ("*** Exception: (unknown)"))
324 Just (PhaseFailed phase code) ->
325 io (putStrLn ("Phase " ++ phase ++ " failed (code "
326 ++ show code ++ ")"))
328 io (putStrLn "Interrupted.")
329 Just (CmdLineError s) ->
330 io (putStrLn s) -- omit the location for CmdLineError
332 io (putStrLn (show other_ghc_ex))
333 showException other_exception
334 = io (putStrLn ("*** Exception: " ++ show other_exception))
336 doCommand (':' : command) = specialCommand command
338 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
341 runStmt :: String -> GHCi [Name]
343 | null (filter (not.isSpace) stmt) = return []
345 = do st <- getGHCiState
346 dflags <- io getDynFlags
347 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
348 (new_cmstate, result) <-
349 io $ withProgName (progname st) $ withArgs (args st) $
350 cmRunStmt (cmstate st) dflags' stmt
351 setGHCiState st{cmstate = new_cmstate}
353 CmRunFailed -> return []
354 CmRunException e -> showException e >> return []
355 CmRunDeadlocked -> io (putStrLn "Deadlocked.") >> return []
356 CmRunOk names -> return names
358 -- possibly print the type and revert CAFs after evaluating an expression
360 = do b <- isOptionSet ShowType
362 when b (mapM_ (showTypeOfName (cmstate st)) names)
364 b <- isOptionSet RevertCAFs
365 io (when b revertCAFs)
369 showTypeOfName :: CmState -> Name -> GHCi ()
370 showTypeOfName cmstate n
371 = do maybe_str <- io (cmTypeOfName cmstate n)
374 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
376 flushEverything :: GHCi ()
378 = io $ do flush_so <- readIORef flush_stdout
380 flush_se <- readIORef flush_stdout
384 specialCommand :: String -> GHCi Bool
385 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
386 specialCommand str = do
387 let (cmd,rest) = break isSpace str
388 cmds <- io (readIORef commands)
389 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
390 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
391 ++ shortHelpText) >> return False)
392 [(_,f)] -> f (dropWhile isSpace rest)
393 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
394 " matches multiple commands (" ++
395 foldr1 (\a b -> a ++ ',':b) (map fst cs)
396 ++ ")") >> return False)
398 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
400 -----------------------------------------------------------------------------
403 help :: String -> GHCi ()
404 help _ = io (putStr helpText)
406 info :: String -> GHCi ()
407 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
410 state <- getGHCiState
411 dflags <- io getDynFlags
413 infoThings cms [] = return cms
414 infoThings cms (name:names) = do
415 (cms, unqual, stuff) <- io (cmInfoThing cms dflags name)
416 io (putStrLn (showSDocForUser unqual (
417 vcat (intersperse (text "") (map showThing stuff))))
421 showThing (ty_thing, fixity)
422 = vcat [ text "-- " <> showTyThing ty_thing,
423 showFixity fixity (getName ty_thing),
424 ppr (ifaceTyThing ty_thing) ]
427 | fix == defaultFixity = empty
428 | otherwise = ppr fix <+>
429 (if isSymOcc (nameOccName name)
431 else char '`' <> ppr name <> char '`')
433 showTyThing (AClass cl)
434 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
435 showTyThing (ATyCon ty)
437 = hcat [ppr ty, text " is a primitive type constructor"]
439 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
440 showTyThing (AnId id)
441 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
444 | isRecordSelector id =
445 case tyConClass_maybe (fieldLabelTyCon (
446 recordSelectorFieldLabel id)) of
447 Nothing -> text "record selector"
448 Just c -> text "method in class " <> ppr c
449 | isDataConWrapId id = text "data constructor"
450 | otherwise = text "variable"
452 -- also print out the source location for home things
454 | isHomePackageName name && isGoodSrcLoc loc
455 = hsep [ text ", defined at", ppr loc ]
458 where loc = nameSrcLoc name
460 cms <- infoThings (cmstate state) names
461 setGHCiState state{ cmstate = cms }
465 addModule :: String -> GHCi ()
467 let files = words str
468 state <- getGHCiState
469 dflags <- io (getDynFlags)
470 io (revertCAFs) -- always revert CAFs on load/add.
471 let new_targets = files ++ targets state
472 (cmstate1, ok, mods) <- io (cmLoadModule (cmstate state) new_targets)
473 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
474 modulesLoadedMsg ok mods
476 setContext :: String -> GHCi ()
478 = throwDyn (CmdLineError "syntax: `:m <module>'")
479 setContext m | not (isUpper (head m)) || not (all isAlphaNumEx (tail m))
480 = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
482 isAlphaNumEx c = isAlphaNum c || c == '_'
484 = do st <- getGHCiState
485 new_cmstate <- io (cmSetContext (cmstate st) str)
486 setGHCiState st{cmstate=new_cmstate}
488 changeDirectory :: String -> GHCi ()
489 changeDirectory ('~':d) = do
490 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
491 io (setCurrentDirectory (tilde ++ '/':d))
492 changeDirectory d = io (setCurrentDirectory d)
494 defineMacro :: String -> GHCi ()
496 let (macro_name, definition) = break isSpace s
497 cmds <- io (readIORef commands)
499 then throwDyn (CmdLineError "invalid macro name")
501 if (macro_name `elem` map fst cmds)
502 then throwDyn (CmdLineError
503 ("command `" ++ macro_name ++ "' is already defined"))
506 -- give the expression a type signature, so we can be sure we're getting
507 -- something of the right type.
508 let new_expr = '(' : definition ++ ") :: String -> IO String"
510 -- compile the expression
512 dflags <- io getDynFlags
513 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
514 setGHCiState st{cmstate = new_cmstate}
517 Just hv -> io (writeIORef commands --
518 ((macro_name, keepGoing (runMacro hv)) : cmds))
520 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
522 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
523 stringLoop (lines str)
525 undefineMacro :: String -> GHCi ()
526 undefineMacro macro_name = do
527 cmds <- io (readIORef commands)
528 if (macro_name `elem` map fst builtin_commands)
529 then throwDyn (CmdLineError
530 ("command `" ++ macro_name ++ "' cannot be undefined"))
532 if (macro_name `notElem` map fst cmds)
533 then throwDyn (CmdLineError
534 ("command `" ++ macro_name ++ "' not defined"))
536 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
538 loadModule :: String -> GHCi ()
539 loadModule str = timeIt (loadModule' str)
542 let files = words str
543 state <- getGHCiState
544 dflags <- io getDynFlags
545 cmstate1 <- io (cmUnload (cmstate state) dflags)
546 setGHCiState state{ cmstate = cmstate1, targets = [] }
547 io (revertCAFs) -- always revert CAFs on load.
548 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 files)
549 setGHCiState state{ cmstate = cmstate2, targets = files }
550 modulesLoadedMsg ok mods
552 reloadModule :: String -> GHCi ()
554 state <- getGHCiState
555 case targets state of
556 [] -> io (putStr "no current target\n")
558 -> do io (revertCAFs) -- always revert CAFs on reload.
559 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) paths)
560 setGHCiState state{ cmstate=new_cmstate }
561 modulesLoadedMsg ok mods
563 reloadModule _ = noArgs ":reload"
566 modulesLoadedMsg ok mods = do
568 | null mods = text "none."
570 punctuate comma (map text mods)) <> text "."
573 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
575 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
578 typeOfExpr :: String -> GHCi ()
580 = do st <- getGHCiState
581 dflags <- io getDynFlags
582 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
583 setGHCiState st{cmstate = new_cmstate}
586 Just tystr -> io (putStrLn tystr)
588 quit :: String -> GHCi Bool
591 shellEscape :: String -> GHCi Bool
592 shellEscape str = io (system str >> return False)
594 ----------------------------------------------------------------------------
597 -- set options in the interpreter. Syntax is exactly the same as the
598 -- ghc command line, except that certain options aren't available (-C,
601 -- This is pretty fragile: most options won't work as expected. ToDo:
602 -- figure out which ones & disallow them.
604 setCmd :: String -> GHCi ()
606 = do st <- getGHCiState
607 let opts = options st
608 io $ putStrLn (showSDoc (
609 text "options currently set: " <>
612 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
616 ("args":args) -> setArgs args
617 ("prog":prog) -> setProg prog
618 wds -> setOptions wds
622 setGHCiState st{ args = args }
626 setGHCiState st{ progname = prog }
628 io (hPutStrLn stderr "syntax: :set prog <progname>")
631 do -- first, deal with the GHCi opts (+s, +t, etc.)
632 let (plus_opts, minus_opts) = partition isPlus wds
633 mapM setOpt plus_opts
635 -- now, the GHC flags
636 pkgs_before <- io (readIORef v_Packages)
637 leftovers <- io (processArgs static_flags minus_opts [])
638 pkgs_after <- io (readIORef v_Packages)
640 -- update things if the users wants more packages
641 when (pkgs_before /= pkgs_after) $
642 newPackages (pkgs_after \\ pkgs_before)
644 -- then, dynamic flags
647 leftovers <- processArgs dynamic_flags leftovers []
650 if (not (null leftovers))
651 then throwDyn (CmdLineError ("unrecognised flags: " ++
656 unsetOptions :: String -> GHCi ()
658 = do -- first, deal with the GHCi opts (+s, +t, etc.)
660 (minus_opts, rest1) = partition isMinus opts
661 (plus_opts, rest2) = partition isPlus rest1
663 if (not (null rest2))
664 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
667 mapM unsetOpt plus_opts
669 -- can't do GHC flags for now
670 if (not (null minus_opts))
671 then throwDyn (CmdLineError "can't unset GHC command-line flags")
674 isMinus ('-':s) = True
677 isPlus ('+':s) = True
681 = case strToGHCiOpt str of
682 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
683 Just o -> setOption o
686 = case strToGHCiOpt str of
687 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
688 Just o -> unsetOption o
690 strToGHCiOpt :: String -> (Maybe GHCiOption)
691 strToGHCiOpt "s" = Just ShowTiming
692 strToGHCiOpt "t" = Just ShowType
693 strToGHCiOpt "r" = Just RevertCAFs
694 strToGHCiOpt _ = Nothing
696 optToStr :: GHCiOption -> String
697 optToStr ShowTiming = "s"
698 optToStr ShowType = "t"
699 optToStr RevertCAFs = "r"
701 newPackages new_pkgs = do
702 state <- getGHCiState
703 dflags <- io getDynFlags
704 cmstate1 <- io (cmUnload (cmstate state) dflags)
705 setGHCiState state{ cmstate = cmstate1, targets = [] }
708 pkgs <- getPackageInfo
709 flushPackageCache pkgs
711 new_pkg_info <- getPackageDetails new_pkgs
712 mapM_ linkPackage (reverse new_pkg_info)
714 -----------------------------------------------------------------------------
717 data GHCiState = GHCiState
721 targets :: [FilePath],
723 options :: [GHCiOption]
727 = ShowTiming -- show time/allocs after evaluation
728 | ShowType -- show the type of expressions
729 | RevertCAFs -- revert CAFs after every evaluation
732 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
733 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
735 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
737 startGHCi :: GHCi a -> GHCiState -> IO a
738 startGHCi g state = do ref <- newIORef state; unGHCi g ref
740 instance Monad GHCi where
741 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
742 return a = GHCi $ \s -> return a
744 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
745 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
746 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
748 getGHCiState = GHCi $ \r -> readIORef r
749 setGHCiState s = GHCi $ \r -> writeIORef r s
751 isOptionSet :: GHCiOption -> GHCi Bool
753 = do st <- getGHCiState
754 return (opt `elem` options st)
756 setOption :: GHCiOption -> GHCi ()
758 = do st <- getGHCiState
759 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
761 unsetOption :: GHCiOption -> GHCi ()
763 = do st <- getGHCiState
764 setGHCiState (st{ options = filter (/= opt) (options st) })
767 io m = GHCi { unGHCi = \s -> m >>= return }
769 -----------------------------------------------------------------------------
770 -- recursive exception handlers
772 -- Don't forget to unblock async exceptions in the handler, or if we're
773 -- in an exception loop (eg. let a = error a in a) the ^C exception
774 -- may never be delivered. Thanks to Marcin for pointing out the bug.
776 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
777 ghciHandle h (GHCi m) = GHCi $ \s ->
778 Exception.catch (m s)
779 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
781 ghciUnblock :: GHCi a -> GHCi a
782 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
784 -----------------------------------------------------------------------------
787 -- Left: full path name of a .o file, including trailing .o
788 -- Right: "unadorned" name of a .DLL/.so
789 -- e.g. On unix "qt" denotes "libqt.so"
790 -- On WinDoze "burble" denotes "burble.DLL"
791 -- addDLL is platform-specific and adds the lib/.so/.DLL
792 -- suffixes platform-dependently; we don't do that here.
794 -- For dynamic objects only, try to find the object file in all the
795 -- directories specified in v_Library_Paths before giving up.
798 = Either FilePath String
800 showLS (Left nm) = "(static) " ++ nm
801 showLS (Right nm) = "(dynamic) " ++ nm
803 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
804 linkPackages cmdline_lib_specs pkgs
805 = do mapM_ linkPackage (reverse pkgs)
806 lib_paths <- readIORef v_Library_paths
807 mapM_ (preloadLib lib_paths) cmdline_lib_specs
808 if (null cmdline_lib_specs)
810 else do putStr "final link ... "
812 if ok then putStrLn "done."
813 else throwDyn (InstallationError "linking extra libraries/objects failed")
815 preloadLib :: [String] -> LibrarySpec -> IO ()
816 preloadLib lib_paths lib_spec
817 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
820 -> do b <- preload_static lib_paths static_ish
821 putStrLn (if b then "done." else "not found")
823 -> -- We add "" to the set of paths to try, so that
824 -- if none of the real paths match, we force addDLL
825 -- to look in the default dynamic-link search paths.
826 do b <- preload_dynamic (lib_paths++[""]) dll_unadorned
827 when (not b) (cantFind lib_paths lib_spec)
830 cantFind :: [String] -> LibrarySpec -> IO ()
832 = do putStr ("failed.\nCan't find " ++ showLS spec
833 ++ " in directories:\n"
834 ++ unlines (map (" "++) paths) )
837 -- not interested in the paths in the static case.
838 preload_static paths name
839 = do b <- doesFileExist name
840 if not b then return False
841 else loadObj name >> return True
843 preload_dynamic [] name
845 preload_dynamic (path:paths) rootname
846 = do maybe_errmsg <- addDLL path rootname
847 if maybe_errmsg /= nullPtr
848 then preload_dynamic paths rootname
852 = (throwDyn . CmdLineError)
853 "user specified .o/.so/.DLL could not be loaded."
855 -- Packages that don't need loading, because the compiler shares them with
856 -- the interpreted program.
857 dont_load_these = [ "gmp", "rts" ]
859 -- Packages that are already linked into GHCi. For mingw32, we only
860 -- skip gmp and rts, since std and after need to load the msvcrt.dll
861 -- library which std depends on.
863 # ifndef mingw32_TARGET_OS
864 = [ "std", "concurrent", "posix", "text", "util" ]
869 linkPackage :: PackageConfig -> IO ()
871 | name pkg `elem` dont_load_these = return ()
874 -- For each obj, try obj.o and if that fails, obj.so.
875 -- Complication: all the .so's must be loaded before any of the .o's.
876 let dirs = library_dirs pkg
877 let objs = hs_libraries pkg ++ extra_libraries pkg
878 classifieds <- mapM (locateOneObj dirs) objs
880 -- Don't load the .so libs if this is a package GHCi is already
881 -- linked against, because we'll already have the .so linked in.
882 let (so_libs, obj_libs) = partition isRight classifieds
883 let sos_first | name pkg `elem` loaded_in_ghci = obj_libs
884 | otherwise = so_libs ++ obj_libs
886 putStr ("Loading package " ++ name pkg ++ " ... ")
887 mapM loadClassified sos_first
888 putStr "linking ... "
890 if ok then putStrLn "done."
891 else panic ("can't load package `" ++ name pkg ++ "'")
893 isRight (Right _) = True
894 isRight (Left _) = False
896 loadClassified :: LibrarySpec -> IO ()
897 loadClassified (Left obj_absolute_filename)
898 = do loadObj obj_absolute_filename
899 loadClassified (Right dll_unadorned)
900 = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
901 if maybe_errmsg == nullPtr
903 else do str <- peekCString maybe_errmsg
904 throwDyn (CmdLineError ("can't load .so/.DLL for: "
905 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
907 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
909 = return (Right obj) -- we assume
910 locateOneObj (d:ds) obj
911 = do let path = d ++ '/':obj ++ ".o"
912 b <- doesFileExist path
913 if b then return (Left path) else locateOneObj ds obj
915 -----------------------------------------------------------------------------
916 -- timing & statistics
918 timeIt :: GHCi a -> GHCi a
920 = do b <- isOptionSet ShowTiming
923 else do allocs1 <- io $ getAllocations
924 time1 <- io $ getCPUTime
926 allocs2 <- io $ getAllocations
927 time2 <- io $ getCPUTime
928 io $ printTimes (allocs2 - allocs1) (time2 - time1)
931 foreign import "getAllocations" getAllocations :: IO Int
933 printTimes :: Int -> Integer -> IO ()
934 printTimes allocs psecs
935 = do let secs = (fromIntegral psecs / (10^12)) :: Float
936 secs_str = showFFloat (Just 2) secs
938 parens (text (secs_str "") <+> text "secs" <> comma <+>
939 int allocs <+> text "bytes")))
941 -----------------------------------------------------------------------------
944 foreign import revertCAFs :: IO () -- make it "safe", just in case