1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.96 2001/10/18 15:26:57 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
64 import PrelGHC ( unsafeCoerce# )
65 import Foreign ( nullPtr )
66 import CString ( peekCString )
68 -----------------------------------------------------------------------------
72 \ / _ \\ /\\ /\\/ __(_)\n\
73 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
74 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
75 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
77 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
79 builtin_commands :: [(String, String -> GHCi Bool)]
81 ("add", keepGoing addModule),
82 ("cd", keepGoing changeDirectory),
83 ("def", keepGoing defineMacro),
84 ("help", keepGoing help),
85 ("?", keepGoing help),
86 ("info", keepGoing info),
87 ("load", keepGoing loadModule),
88 ("module", keepGoing setContext),
89 ("reload", keepGoing reloadModule),
90 ("set", keepGoing setOptions),
91 ("type", keepGoing typeOfExpr),
92 ("unset", keepGoing unsetOptions),
93 ("undef", keepGoing undefineMacro),
97 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
98 keepGoing a str = a str >> return False
100 shortHelpText = "use :? for help.\n"
103 \ Commands available from the prompt:\n\
105 \ <stmt> evaluate/run <stmt>\n\
106 \ :add <filename> ... add module(s) to the current target set\n\
107 \ :cd <dir> change directory to <dir>\n\
108 \ :def <cmd> <expr> define a command :<cmd>\n\
109 \ :help, :? display this list of commands\n\
110 \ :info [<name> ...] display information about the given names\n\
111 \ :load <filename> ... load module(s) and their dependents\n\
112 \ :module <mod> set the context for expression evaluation to <mod>\n\
113 \ :reload reload the current module set\n\
114 \ :set <option> ... set options\n\
115 \ :undef <cmd> undefine user-defined command :<cmd>\n\
116 \ :type <expr> show the type of <expr>\n\
117 \ :unset <option> ... unset options\n\
119 \ :!<command> run the shell command <command>\n\
121 \ Options for `:set' and `:unset':\n\
123 \ +r revert top-level expressions after each evaluation\n\
124 \ +s print timing/memory stats after each evaluation\n\
125 \ +t print type after evaluation\n\
126 \ -<flags> most GHC command line flags can also be set here\n\
127 \ (eg. -v2, -fglasgow-exts, etc.)\n\
130 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
131 interactiveUI cmstate paths cmdline_libs = do
133 hSetBuffering stdout NoBuffering
135 -- link in the available packages
136 pkgs <- getPackageInfo
138 linkPackages cmdline_libs pkgs
140 (cmstate, ok, mods) <-
142 [] -> return (cmstate, True, [])
143 _ -> cmLoadModule cmstate paths
145 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
149 dflags <- getDynFlags
151 (cmstate, maybe_hval)
152 <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering >> IO.hSetBuffering IO.stderr IO.NoBuffering"
154 Just hval -> unsafeCoerce# hval :: IO ()
155 _ -> panic "interactiveUI:buffering"
157 (cmstate, maybe_hval)
158 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
160 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
161 _ -> panic "interactiveUI:stderr"
163 (cmstate, maybe_hval)
164 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
166 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
167 _ -> panic "interactiveUI:stdout"
169 startGHCi runGHCi GHCiState{ targets = paths,
173 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
174 Readline.resetTerminal Nothing
182 read_dot_files <- io (readIORef v_Read_DotGHCi)
184 when (read_dot_files) $ do
187 exists <- io (doesFileExist file)
189 dir_ok <- io (checkPerms ".")
190 file_ok <- io (checkPerms file)
191 when (dir_ok && file_ok) $ do
192 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
195 Right hdl -> fileLoop hdl False
197 when (read_dot_files) $ do
198 -- Read in $HOME/.ghci
199 either_dir <- io (IO.try (getEnv "HOME"))
203 cwd <- io (getCurrentDirectory)
204 when (dir /= cwd) $ do
205 let file = dir ++ "/.ghci"
206 ok <- io (checkPerms file)
208 either_hdl <- io (IO.try (openFile file ReadMode))
211 Right hdl -> fileLoop hdl False
216 io $ do putStrLn "Leaving GHCi."
220 -- ignore ^C exceptions caught here
221 ghciHandleDyn (\e -> case e of Interrupted -> ghciUnblock interactiveLoop
222 _other -> return ()) $ do
223 -- read commands from stdin
224 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
231 -- NOTE: We only read .ghci files if they are owned by the current user,
232 -- and aren't world writable. Otherwise, we could be accidentally
233 -- running code planted by a malicious third party.
235 -- Furthermore, We only read ./.ghci if . is owned by the current user
236 -- and isn't writable by anyone else. I think this is sufficient: we
237 -- don't need to check .. and ../.. etc. because "." always refers to
238 -- the same directory while a process is running.
240 checkPerms :: String -> IO Bool
242 handle (\_ -> return False) $ do
243 #ifdef mingw32_TARGET_OS
246 st <- getFileStatus name
248 if fileOwner st /= me then do
249 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
252 let mode = fileMode st
253 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
254 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
256 putStrLn $ "*** WARNING: " ++ name ++
257 " is writable by someone else, IGNORING!"
262 fileLoop :: Handle -> Bool -> GHCi ()
263 fileLoop hdl prompt = do
265 mod <- io (cmGetContext (cmstate st))
266 when prompt (io (putStr (mod ++ "> ")))
267 l <- io (IO.try (hGetLine hdl))
269 Left e | isEOFError e -> return ()
270 | otherwise -> throw e
272 case remove_spaces l of
273 "" -> fileLoop hdl prompt
274 l -> do quit <- runCommand l
275 if quit then return () else fileLoop hdl prompt
277 stringLoop :: [String] -> GHCi ()
278 stringLoop [] = return ()
279 stringLoop (s:ss) = do
281 case remove_spaces s of
283 l -> do quit <- runCommand l
284 if quit then return () else stringLoop ss
286 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
287 readlineLoop :: GHCi ()
290 mod <- io (cmGetContext (cmstate st))
292 l <- io (readline (mod ++ "> "))
296 case remove_spaces l of
301 if quit then return () else readlineLoop
304 -- Top level exception handler, just prints out the exception
306 runCommand :: String -> GHCi Bool
308 ghciHandle ( \exception -> do
310 showException exception
315 showException (DynException dyn) =
316 case fromDynamic dyn of
318 io (putStrLn ("*** Exception: (unknown)"))
319 Just (PhaseFailed phase code) ->
320 io (putStrLn ("Phase " ++ phase ++ " failed (code "
321 ++ show code ++ ")"))
323 io (putStrLn "Interrupted.")
324 Just (CmdLineError s) ->
325 io (putStrLn s) -- omit the location for CmdLineError
327 io (putStrLn (show other_ghc_ex))
328 showException other_exception
329 = io (putStrLn ("*** Exception: " ++ show other_exception))
331 doCommand (':' : command) = specialCommand command
333 = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff)
336 -- Returns True if the expr was successfully parsed, renamed and
338 runStmt :: String -> GHCi (Maybe [Name])
340 | null (filter (not.isSpace) stmt)
343 = do st <- getGHCiState
344 dflags <- io getDynFlags
345 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
346 (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt)
347 setGHCiState st{cmstate = new_cmstate}
350 -- possibly print the type and revert CAFs after evaluating an expression
351 finishEvalExpr Nothing = return False
352 finishEvalExpr (Just names)
353 = do b <- isOptionSet ShowType
355 when b (mapM_ (showTypeOfName (cmstate st)) names)
357 b <- isOptionSet RevertCAFs
358 io (when b revertCAFs)
362 showTypeOfName :: CmState -> Name -> GHCi ()
363 showTypeOfName cmstate n
364 = do maybe_str <- io (cmTypeOfName cmstate n)
367 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
369 flushEverything :: GHCi ()
371 = io $ do flush_so <- readIORef flush_stdout
373 flush_se <- readIORef flush_stdout
377 specialCommand :: String -> GHCi Bool
378 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
379 specialCommand str = do
380 let (cmd,rest) = break isSpace str
381 cmds <- io (readIORef commands)
382 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
383 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
384 ++ shortHelpText) >> return False)
385 [(_,f)] -> f (dropWhile isSpace rest)
386 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
387 " matches multiple commands (" ++
388 foldr1 (\a b -> a ++ ',':b) (map fst cs)
389 ++ ")") >> return False)
391 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
393 -----------------------------------------------------------------------------
396 help :: String -> GHCi ()
397 help _ = io (putStr helpText)
399 info :: String -> GHCi ()
400 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
403 state <- getGHCiState
404 dflags <- io getDynFlags
406 infoThings cms [] = return cms
407 infoThings cms (name:names) = do
408 (cms, unqual, stuff) <- io (cmInfoThing cms dflags name)
409 io (putStrLn (showSDocForUser unqual (
410 vcat (intersperse (text "") (map showThing stuff))))
414 showThing (ty_thing, fixity)
415 = vcat [ text "-- " <> showTyThing ty_thing,
416 showFixity fixity (getName ty_thing),
417 ppr (ifaceTyThing ty_thing) ]
420 | fix == defaultFixity = empty
421 | otherwise = ppr fix <+>
422 (if isSymOcc (nameOccName name)
424 else char '`' <> ppr name <> char '`')
426 showTyThing (AClass cl)
427 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
428 showTyThing (ATyCon ty)
430 = hcat [ppr ty, text " is a primitive type constructor"]
432 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
433 showTyThing (AnId id)
434 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
437 | isRecordSelector id =
438 case tyConClass_maybe (fieldLabelTyCon (
439 recordSelectorFieldLabel id)) of
440 Nothing -> text "record selector"
441 Just c -> text "method in class " <> ppr c
442 | isDataConWrapId id = text "data constructor"
443 | otherwise = text "variable"
445 -- also print out the source location for home things
447 | isHomePackageName name && isGoodSrcLoc loc
448 = hsep [ text ", defined at", ppr loc ]
451 where loc = nameSrcLoc name
453 cms <- infoThings (cmstate state) names
454 setGHCiState state{ cmstate = cms }
458 addModule :: String -> GHCi ()
460 let files = words str
461 state <- getGHCiState
462 dflags <- io (getDynFlags)
463 io (revertCAFs) -- always revert CAFs on load/add.
464 let new_targets = files ++ targets state
465 (cmstate1, ok, mods) <- io (cmLoadModule (cmstate state) new_targets)
466 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
467 modulesLoadedMsg ok mods
469 setContext :: String -> GHCi ()
471 = throwDyn (CmdLineError "syntax: `:m <module>'")
472 setContext m | not (isUpper (head m)) || not (all isAlphaNumEx (tail m))
473 = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
475 isAlphaNumEx c = isAlphaNum c || c == '_'
477 = do st <- getGHCiState
478 new_cmstate <- io (cmSetContext (cmstate st) str)
479 setGHCiState st{cmstate=new_cmstate}
481 changeDirectory :: String -> GHCi ()
482 changeDirectory ('~':d) = do
483 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
484 io (setCurrentDirectory (tilde ++ '/':d))
485 changeDirectory d = io (setCurrentDirectory d)
487 defineMacro :: String -> GHCi ()
489 let (macro_name, definition) = break isSpace s
490 cmds <- io (readIORef commands)
492 then throwDyn (CmdLineError "invalid macro name")
494 if (macro_name `elem` map fst cmds)
495 then throwDyn (CmdLineError
496 ("command `" ++ macro_name ++ "' is already defined"))
499 -- give the expression a type signature, so we can be sure we're getting
500 -- something of the right type.
501 let new_expr = '(' : definition ++ ") :: String -> IO String"
503 -- compile the expression
505 dflags <- io getDynFlags
506 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
507 setGHCiState st{cmstate = new_cmstate}
510 Just hv -> io (writeIORef commands --
511 ((macro_name, keepGoing (runMacro hv)) : cmds))
513 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
515 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
516 stringLoop (lines str)
518 undefineMacro :: String -> GHCi ()
519 undefineMacro macro_name = do
520 cmds <- io (readIORef commands)
521 if (macro_name `elem` map fst builtin_commands)
522 then throwDyn (CmdLineError
523 ("command `" ++ macro_name ++ "' cannot be undefined"))
525 if (macro_name `notElem` map fst cmds)
526 then throwDyn (CmdLineError
527 ("command `" ++ macro_name ++ "' not defined"))
529 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
531 loadModule :: String -> GHCi ()
532 loadModule str = timeIt (loadModule' str)
535 let files = words str
536 state <- getGHCiState
537 dflags <- io getDynFlags
538 cmstate1 <- io (cmUnload (cmstate state) dflags)
539 setGHCiState state{ cmstate = cmstate1, targets = [] }
540 io (revertCAFs) -- always revert CAFs on load.
541 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 files)
542 setGHCiState state{ cmstate = cmstate2, targets = files }
543 modulesLoadedMsg ok mods
545 reloadModule :: String -> GHCi ()
547 state <- getGHCiState
548 case targets state of
549 [] -> io (putStr "no current target\n")
551 -> do io (revertCAFs) -- always revert CAFs on reload.
552 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) paths)
553 setGHCiState state{ cmstate=new_cmstate }
554 modulesLoadedMsg ok mods
556 reloadModule _ = noArgs ":reload"
559 modulesLoadedMsg ok mods = do
561 | null mods = text "none."
563 punctuate comma (map text mods)) <> text "."
566 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
568 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
571 typeOfExpr :: String -> GHCi ()
573 = do st <- getGHCiState
574 dflags <- io getDynFlags
575 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
576 setGHCiState st{cmstate = new_cmstate}
579 Just tystr -> io (putStrLn tystr)
581 quit :: String -> GHCi Bool
584 shellEscape :: String -> GHCi Bool
585 shellEscape str = io (system str >> return False)
587 ----------------------------------------------------------------------------
590 -- set options in the interpreter. Syntax is exactly the same as the
591 -- ghc command line, except that certain options aren't available (-C,
594 -- This is pretty fragile: most options won't work as expected. ToDo:
595 -- figure out which ones & disallow them.
597 setOptions :: String -> GHCi ()
599 = do st <- getGHCiState
600 let opts = options st
601 io $ putStrLn (showSDoc (
602 text "options currently set: " <>
605 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
608 = do -- first, deal with the GHCi opts (+s, +t, etc.)
609 let (plus_opts, minus_opts) = partition isPlus (words str)
610 mapM setOpt plus_opts
612 -- now, the GHC flags
613 pkgs_before <- io (readIORef v_Packages)
614 leftovers <- io (processArgs static_flags minus_opts [])
615 pkgs_after <- io (readIORef v_Packages)
617 -- update things if the users wants more packages
618 when (pkgs_before /= pkgs_after) $
619 newPackages (pkgs_after \\ pkgs_before)
621 -- then, dynamic flags
624 leftovers <- processArgs dynamic_flags leftovers []
627 if (not (null leftovers))
628 then throwDyn (CmdLineError ("unrecognised flags: " ++
633 unsetOptions :: String -> GHCi ()
635 = do -- first, deal with the GHCi opts (+s, +t, etc.)
637 (minus_opts, rest1) = partition isMinus opts
638 (plus_opts, rest2) = partition isPlus rest1
640 if (not (null rest2))
641 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
644 mapM unsetOpt plus_opts
646 -- can't do GHC flags for now
647 if (not (null minus_opts))
648 then throwDyn (CmdLineError "can't unset GHC command-line flags")
651 isMinus ('-':s) = True
654 isPlus ('+':s) = True
658 = case strToGHCiOpt str of
659 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
660 Just o -> setOption o
663 = case strToGHCiOpt str of
664 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
665 Just o -> unsetOption o
667 strToGHCiOpt :: String -> (Maybe GHCiOption)
668 strToGHCiOpt "s" = Just ShowTiming
669 strToGHCiOpt "t" = Just ShowType
670 strToGHCiOpt "r" = Just RevertCAFs
671 strToGHCiOpt _ = Nothing
673 optToStr :: GHCiOption -> String
674 optToStr ShowTiming = "s"
675 optToStr ShowType = "t"
676 optToStr RevertCAFs = "r"
678 newPackages new_pkgs = do
679 state <- getGHCiState
680 dflags <- io getDynFlags
681 cmstate1 <- io (cmUnload (cmstate state) dflags)
682 setGHCiState state{ cmstate = cmstate1, targets = [] }
685 pkgs <- getPackageInfo
686 flushPackageCache pkgs
688 new_pkg_info <- getPackageDetails new_pkgs
689 mapM_ linkPackage (reverse new_pkg_info)
691 -----------------------------------------------------------------------------
694 data GHCiState = GHCiState
696 targets :: [FilePath],
698 options :: [GHCiOption]
702 = ShowTiming -- show time/allocs after evaluation
703 | ShowType -- show the type of expressions
704 | RevertCAFs -- revert CAFs after every evaluation
707 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
708 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
710 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
712 startGHCi :: GHCi a -> GHCiState -> IO a
713 startGHCi g state = do ref <- newIORef state; unGHCi g ref
715 instance Monad GHCi where
716 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
717 return a = GHCi $ \s -> return a
719 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
720 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
721 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
723 getGHCiState = GHCi $ \r -> readIORef r
724 setGHCiState s = GHCi $ \r -> writeIORef r s
726 isOptionSet :: GHCiOption -> GHCi Bool
728 = do st <- getGHCiState
729 return (opt `elem` options st)
731 setOption :: GHCiOption -> GHCi ()
733 = do st <- getGHCiState
734 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
736 unsetOption :: GHCiOption -> GHCi ()
738 = do st <- getGHCiState
739 setGHCiState (st{ options = filter (/= opt) (options st) })
742 io m = GHCi { unGHCi = \s -> m >>= return }
744 -----------------------------------------------------------------------------
745 -- recursive exception handlers
747 -- Don't forget to unblock async exceptions in the handler, or if we're
748 -- in an exception loop (eg. let a = error a in a) the ^C exception
749 -- may never be delivered. Thanks to Marcin for pointing out the bug.
751 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
752 ghciHandle h (GHCi m) = GHCi $ \s ->
753 Exception.catch (m s)
754 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
756 ghciUnblock :: GHCi a -> GHCi a
757 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
759 -----------------------------------------------------------------------------
762 -- Left: full path name of a .o file, including trailing .o
763 -- Right: "unadorned" name of a .DLL/.so
764 -- e.g. On unix "qt" denotes "libqt.so"
765 -- On WinDoze "burble" denotes "burble.DLL"
766 -- addDLL is platform-specific and adds the lib/.so/.DLL
767 -- suffixes platform-dependently; we don't do that here.
769 -- For dynamic objects only, try to find the object file in all the
770 -- directories specified in v_Library_Paths before giving up.
773 = Either FilePath String
775 showLS (Left nm) = "(static) " ++ nm
776 showLS (Right nm) = "(dynamic) " ++ nm
778 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
779 linkPackages cmdline_lib_specs pkgs
780 = do mapM_ linkPackage (reverse pkgs)
781 lib_paths <- readIORef v_Library_paths
782 mapM_ (preloadLib lib_paths) cmdline_lib_specs
783 if (null cmdline_lib_specs)
785 else do putStr "final link ... "
787 if ok then putStrLn "done."
788 else throwDyn (InstallationError "linking extra libraries/objects failed")
790 preloadLib :: [String] -> LibrarySpec -> IO ()
791 preloadLib lib_paths lib_spec
792 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
795 -> do b <- preload_static lib_paths static_ish
796 putStrLn (if b then "done." else "not found")
798 -> -- We add "" to the set of paths to try, so that
799 -- if none of the real paths match, we force addDLL
800 -- to look in the default dynamic-link search paths.
801 do b <- preload_dynamic (lib_paths++[""]) dll_unadorned
802 when (not b) (cantFind lib_paths lib_spec)
805 cantFind :: [String] -> LibrarySpec -> IO ()
807 = do putStr ("failed.\nCan't find " ++ showLS spec
808 ++ " in directories:\n"
809 ++ unlines (map (" "++) paths) )
812 -- not interested in the paths in the static case.
813 preload_static paths name
814 = do b <- doesFileExist name
815 if not b then return False
816 else loadObj name >> return True
818 preload_dynamic [] name
820 preload_dynamic (path:paths) rootname
821 = do maybe_errmsg <- addDLL path rootname
822 if maybe_errmsg /= nullPtr
823 then preload_dynamic paths rootname
827 = (throwDyn . CmdLineError)
828 "user specified .o/.so/.DLL could not be loaded."
830 -- Packages that don't need loading, because the compiler shares them with
831 -- the interpreted program.
832 dont_load_these = [ "gmp", "rts" ]
834 -- Packages that are already linked into GHCi. For mingw32, we only
835 -- skip gmp and rts, since std and after need to load the msvcrt.dll
836 -- library which std depends on.
838 # ifndef mingw32_TARGET_OS
839 = [ "std", "concurrent", "posix", "text", "util" ]
844 linkPackage :: PackageConfig -> IO ()
846 | name pkg `elem` dont_load_these = return ()
849 -- For each obj, try obj.o and if that fails, obj.so.
850 -- Complication: all the .so's must be loaded before any of the .o's.
851 let dirs = library_dirs pkg
852 let objs = hs_libraries pkg ++ extra_libraries pkg
853 classifieds <- mapM (locateOneObj dirs) objs
855 -- Don't load the .so libs if this is a package GHCi is already
856 -- linked against, because we'll already have the .so linked in.
857 let (so_libs, obj_libs) = partition isRight classifieds
858 let sos_first | name pkg `elem` loaded_in_ghci = obj_libs
859 | otherwise = so_libs ++ obj_libs
861 putStr ("Loading package " ++ name pkg ++ " ... ")
862 mapM loadClassified sos_first
863 putStr "linking ... "
865 if ok then putStrLn "done."
866 else panic ("can't load package `" ++ name pkg ++ "'")
868 isRight (Right _) = True
869 isRight (Left _) = False
871 loadClassified :: LibrarySpec -> IO ()
872 loadClassified (Left obj_absolute_filename)
873 = do loadObj obj_absolute_filename
874 loadClassified (Right dll_unadorned)
875 = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
876 if maybe_errmsg == nullPtr
878 else do str <- peekCString maybe_errmsg
879 throwDyn (CmdLineError ("can't load .so/.DLL for: "
880 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
882 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
884 = return (Right obj) -- we assume
885 locateOneObj (d:ds) obj
886 = do let path = d ++ '/':obj ++ ".o"
887 b <- doesFileExist path
888 if b then return (Left path) else locateOneObj ds obj
890 -----------------------------------------------------------------------------
891 -- timing & statistics
893 timeIt :: GHCi a -> GHCi a
895 = do b <- isOptionSet ShowTiming
898 else do allocs1 <- io $ getAllocations
899 time1 <- io $ getCPUTime
901 allocs2 <- io $ getAllocations
902 time2 <- io $ getCPUTime
903 io $ printTimes (allocs2 - allocs1) (time2 - time1)
906 foreign import "getAllocations" getAllocations :: IO Int
908 printTimes :: Int -> Integer -> IO ()
909 printTimes allocs psecs
910 = do let secs = (fromIntegral psecs / (10^12)) :: Float
911 secs_str = showFFloat (Just 2) secs
913 parens (text (secs_str "") <+> text "secs" <> comma <+>
914 int allocs <+> text "bytes")))
916 -----------------------------------------------------------------------------
919 foreign import revertCAFs :: IO () -- make it "safe", just in case