1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.99 2001/10/23 17:18:38 sof Exp $
5 -- GHC Interactive User Interface
7 -- (c) The GHC Team 2000
9 -----------------------------------------------------------------------------
10 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
12 #include "../includes/config.h"
13 #include "HsVersions.h"
17 import HscTypes ( TyThing(..) )
24 import Finder ( flushPackageCache )
26 import Id ( isRecordSelector, recordSelectorFieldLabel,
27 isDataConWrapId, idName )
28 import Class ( className )
29 import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon )
30 import FieldLabel ( fieldLabelTyCon )
31 import SrcLoc ( isGoodSrcLoc )
32 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
34 import OccName ( isSymOcc )
35 import BasicTypes ( defaultFixity )
37 import CmdLineOpts ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset )
38 import Panic ( GhcException(..) )
41 #ifndef mingw32_TARGET_OS
47 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
61 import Monad ( when, join )
63 import PrelGHC ( unsafeCoerce# )
64 import Foreign ( nullPtr )
65 import CString ( peekCString )
67 -----------------------------------------------------------------------------
71 \ / _ \\ /\\ /\\/ __(_)\n\
72 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
73 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
74 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
76 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
78 builtin_commands :: [(String, String -> GHCi Bool)]
80 ("add", keepGoing addModule),
81 ("cd", keepGoing changeDirectory),
82 ("def", keepGoing defineMacro),
83 ("help", keepGoing help),
84 ("?", keepGoing help),
85 ("info", keepGoing info),
86 ("load", keepGoing loadModule),
87 ("module", keepGoing setContext),
88 ("reload", keepGoing reloadModule),
89 ("set", keepGoing setCmd),
90 ("type", keepGoing typeOfExpr),
91 ("unset", keepGoing unsetOptions),
92 ("undef", keepGoing undefineMacro),
96 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
97 keepGoing a str = a str >> return False
99 shortHelpText = "use :? for help.\n"
102 \ Commands available from the prompt:\n\
104 \ <stmt> evaluate/run <stmt>\n\
105 \ :add <filename> ... add module(s) to the current target set\n\
106 \ :cd <dir> change directory to <dir>\n\
107 \ :def <cmd> <expr> define a command :<cmd>\n\
108 \ :help, :? display this list of commands\n\
109 \ :info [<name> ...] display information about the given names\n\
110 \ :load <filename> ... load module(s) and their dependents\n\
111 \ :module <mod> set the context for expression evaluation to <mod>\n\
112 \ :reload reload the current module set\n\
113 \ :set <option> ... set options\n\
114 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
115 \ :set prog <progname> set the value returned by System.getProgName\n\
116 \ :undef <cmd> undefine user-defined command :<cmd>\n\
117 \ :type <expr> show the type of <expr>\n\
118 \ :unset <option> ... unset options\n\
120 \ :!<command> run the shell command <command>\n\
122 \ Options for `:set' and `:unset':\n\
124 \ +r revert top-level expressions after each evaluation\n\
125 \ +s print timing/memory stats after each evaluation\n\
126 \ +t print type after evaluation\n\
127 \ -<flags> most GHC command line flags can also be set here\n\
128 \ (eg. -v2, -fglasgow-exts, etc.)\n\
131 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
132 interactiveUI cmstate paths cmdline_libs = do
134 hSetBuffering stdout NoBuffering
136 -- link in the available packages
137 pkgs <- getPackageInfo
139 linkPackages cmdline_libs pkgs
141 (cmstate, ok, mods) <-
143 [] -> return (cmstate, True, [])
144 _ -> cmLoadModule cmstate paths
146 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
150 dflags <- getDynFlags
152 (cmstate, maybe_hval)
153 <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering >> IO.hSetBuffering IO.stderr IO.NoBuffering"
155 Just hval -> unsafeCoerce# hval :: IO ()
156 _ -> panic "interactiveUI:buffering"
158 (cmstate, maybe_hval)
159 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
161 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
162 _ -> panic "interactiveUI:stderr"
164 (cmstate, maybe_hval)
165 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
167 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
168 _ -> panic "interactiveUI:stdout"
170 startGHCi runGHCi GHCiState{ progname = "<interactive>",
176 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
177 Readline.resetTerminal Nothing
185 read_dot_files <- io (readIORef v_Read_DotGHCi)
187 when (read_dot_files) $ do
190 exists <- io (doesFileExist file)
192 dir_ok <- io (checkPerms ".")
193 file_ok <- io (checkPerms file)
194 when (dir_ok && file_ok) $ do
195 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
198 Right hdl -> fileLoop hdl False
200 when (read_dot_files) $ do
201 -- Read in $HOME/.ghci
202 either_dir <- io (IO.try (getEnv "HOME"))
206 cwd <- io (getCurrentDirectory)
207 when (dir /= cwd) $ do
208 let file = dir ++ "/.ghci"
209 ok <- io (checkPerms file)
211 either_hdl <- io (IO.try (openFile file ReadMode))
214 Right hdl -> fileLoop hdl False
219 io $ do putStrLn "Leaving GHCi."
223 -- ignore ^C exceptions caught here
224 ghciHandleDyn (\e -> case e of Interrupted -> ghciUnblock interactiveLoop
225 _other -> return ()) $ do
226 -- read commands from stdin
227 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
234 -- NOTE: We only read .ghci files if they are owned by the current user,
235 -- and aren't world writable. Otherwise, we could be accidentally
236 -- running code planted by a malicious third party.
238 -- Furthermore, We only read ./.ghci if . is owned by the current user
239 -- and isn't writable by anyone else. I think this is sufficient: we
240 -- don't need to check .. and ../.. etc. because "." always refers to
241 -- the same directory while a process is running.
243 checkPerms :: String -> IO Bool
245 handle (\_ -> return False) $ do
246 #ifdef mingw32_TARGET_OS
249 st <- getFileStatus name
251 if fileOwner st /= me then do
252 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
255 let mode = fileMode st
256 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
257 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
259 putStrLn $ "*** WARNING: " ++ name ++
260 " is writable by someone else, IGNORING!"
265 fileLoop :: Handle -> Bool -> GHCi ()
266 fileLoop hdl prompt = do
268 mod <- io (cmGetContext (cmstate st))
269 when prompt (io (putStr (mod ++ "> ")))
270 l <- io (IO.try (hGetLine hdl))
272 Left e | isEOFError e -> return ()
273 | otherwise -> throw e
275 case remove_spaces l of
276 "" -> fileLoop hdl prompt
277 l -> do quit <- runCommand l
278 if quit then return () else fileLoop hdl prompt
280 stringLoop :: [String] -> GHCi ()
281 stringLoop [] = return ()
282 stringLoop (s:ss) = do
284 case remove_spaces s of
286 l -> do quit <- runCommand l
287 if quit then return () else stringLoop ss
289 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
290 readlineLoop :: GHCi ()
293 mod <- io (cmGetContext (cmstate st))
295 l <- io (readline (mod ++ "> "))
299 case remove_spaces l of
304 if quit then return () else readlineLoop
307 -- Top level exception handler, just prints out the exception
309 runCommand :: String -> GHCi Bool
311 ghciHandle ( \exception -> do
313 showException exception
318 showException (DynException dyn) =
319 case fromDynamic dyn of
321 io (putStrLn ("*** Exception: (unknown)"))
322 Just (PhaseFailed phase code) ->
323 io (putStrLn ("Phase " ++ phase ++ " failed (code "
324 ++ show code ++ ")"))
326 io (putStrLn "Interrupted.")
327 Just (CmdLineError s) ->
328 io (putStrLn s) -- omit the location for CmdLineError
330 io (putStrLn (show other_ghc_ex))
331 showException other_exception
332 = io (putStrLn ("*** Exception: " ++ show other_exception))
334 doCommand (':' : command) = specialCommand command
336 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
339 runStmt :: String -> GHCi [Name]
341 | null (filter (not.isSpace) stmt) = return []
343 = do st <- getGHCiState
344 dflags <- io getDynFlags
345 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
346 (new_cmstate, result) <-
347 io $ withProgName (progname st) $ withArgs (args st) $
348 cmRunStmt (cmstate st) dflags' stmt
349 setGHCiState st{cmstate = new_cmstate}
351 CmRunFailed -> return []
352 CmRunException e -> showException e >> return []
353 CmRunDeadlocked -> io (putStrLn "Deadlocked.") >> return []
354 CmRunOk names -> return names
356 -- possibly print the type and revert CAFs after evaluating an expression
358 = do b <- isOptionSet ShowType
360 when b (mapM_ (showTypeOfName (cmstate st)) names)
362 b <- isOptionSet RevertCAFs
363 io (when b revertCAFs)
367 showTypeOfName :: CmState -> Name -> GHCi ()
368 showTypeOfName cmstate n
369 = do maybe_str <- io (cmTypeOfName cmstate n)
372 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
374 flushEverything :: GHCi ()
376 = io $ do Monad.join (readIORef flush_stdout)
377 Monad.join (readIORef flush_stderr)
380 specialCommand :: String -> GHCi Bool
381 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
382 specialCommand str = do
383 let (cmd,rest) = break isSpace str
384 cmds <- io (readIORef commands)
385 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
386 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
387 ++ shortHelpText) >> return False)
388 [(_,f)] -> f (dropWhile isSpace rest)
389 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
390 " matches multiple commands (" ++
391 foldr1 (\a b -> a ++ ',':b) (map fst cs)
392 ++ ")") >> return False)
394 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
396 -----------------------------------------------------------------------------
399 help :: String -> GHCi ()
400 help _ = io (putStr helpText)
402 info :: String -> GHCi ()
403 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
406 state <- getGHCiState
407 dflags <- io getDynFlags
409 infoThings cms [] = return cms
410 infoThings cms (name:names) = do
411 (cms, unqual, stuff) <- io (cmInfoThing cms dflags name)
412 io (putStrLn (showSDocForUser unqual (
413 vcat (intersperse (text "") (map showThing stuff))))
417 showThing (ty_thing, fixity)
418 = vcat [ text "-- " <> showTyThing ty_thing,
419 showFixity fixity (getName ty_thing),
420 ppr (ifaceTyThing ty_thing) ]
423 | fix == defaultFixity = empty
424 | otherwise = ppr fix <+>
425 (if isSymOcc (nameOccName name)
427 else char '`' <> ppr name <> char '`')
429 showTyThing (AClass cl)
430 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
431 showTyThing (ATyCon ty)
433 = hcat [ppr ty, text " is a primitive type constructor"]
435 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
436 showTyThing (AnId id)
437 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
440 | isRecordSelector id =
441 case tyConClass_maybe (fieldLabelTyCon (
442 recordSelectorFieldLabel id)) of
443 Nothing -> text "record selector"
444 Just c -> text "method in class " <> ppr c
445 | isDataConWrapId id = text "data constructor"
446 | otherwise = text "variable"
448 -- also print out the source location for home things
450 | isHomePackageName name && isGoodSrcLoc loc
451 = hsep [ text ", defined at", ppr loc ]
454 where loc = nameSrcLoc name
456 cms <- infoThings (cmstate state) names
457 setGHCiState state{ cmstate = cms }
461 addModule :: String -> GHCi ()
463 let files = words str
464 state <- getGHCiState
465 dflags <- io (getDynFlags)
466 io (revertCAFs) -- always revert CAFs on load/add.
467 let new_targets = files ++ targets state
468 (cmstate1, ok, mods) <- io (cmLoadModule (cmstate state) new_targets)
469 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
470 modulesLoadedMsg ok mods
472 setContext :: String -> GHCi ()
474 = throwDyn (CmdLineError "syntax: `:m <module>'")
475 setContext m | not (isUpper (head m)) || not (all isAlphaNumEx (tail m))
476 = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
478 isAlphaNumEx c = isAlphaNum c || c == '_'
480 = do st <- getGHCiState
481 new_cmstate <- io (cmSetContext (cmstate st) str)
482 setGHCiState st{cmstate=new_cmstate}
484 changeDirectory :: String -> GHCi ()
485 changeDirectory ('~':d) = do
486 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
487 io (setCurrentDirectory (tilde ++ '/':d))
488 changeDirectory d = io (setCurrentDirectory d)
490 defineMacro :: String -> GHCi ()
492 let (macro_name, definition) = break isSpace s
493 cmds <- io (readIORef commands)
495 then throwDyn (CmdLineError "invalid macro name")
497 if (macro_name `elem` map fst cmds)
498 then throwDyn (CmdLineError
499 ("command `" ++ macro_name ++ "' is already defined"))
502 -- give the expression a type signature, so we can be sure we're getting
503 -- something of the right type.
504 let new_expr = '(' : definition ++ ") :: String -> IO String"
506 -- compile the expression
508 dflags <- io getDynFlags
509 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
510 setGHCiState st{cmstate = new_cmstate}
513 Just hv -> io (writeIORef commands --
514 ((macro_name, keepGoing (runMacro hv)) : cmds))
516 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
518 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
519 stringLoop (lines str)
521 undefineMacro :: String -> GHCi ()
522 undefineMacro macro_name = do
523 cmds <- io (readIORef commands)
524 if (macro_name `elem` map fst builtin_commands)
525 then throwDyn (CmdLineError
526 ("command `" ++ macro_name ++ "' cannot be undefined"))
528 if (macro_name `notElem` map fst cmds)
529 then throwDyn (CmdLineError
530 ("command `" ++ macro_name ++ "' not defined"))
532 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
534 loadModule :: String -> GHCi ()
535 loadModule str = timeIt (loadModule' str)
538 let files = words str
539 state <- getGHCiState
540 dflags <- io getDynFlags
541 cmstate1 <- io (cmUnload (cmstate state) dflags)
542 setGHCiState state{ cmstate = cmstate1, targets = [] }
543 io (revertCAFs) -- always revert CAFs on load.
544 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 files)
545 setGHCiState state{ cmstate = cmstate2, targets = files }
546 modulesLoadedMsg ok mods
548 reloadModule :: String -> GHCi ()
550 state <- getGHCiState
551 case targets state of
552 [] -> io (putStr "no current target\n")
554 -> do io (revertCAFs) -- always revert CAFs on reload.
555 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) paths)
556 setGHCiState state{ cmstate=new_cmstate }
557 modulesLoadedMsg ok mods
559 reloadModule _ = noArgs ":reload"
562 modulesLoadedMsg ok mods = do
564 | null mods = text "none."
566 punctuate comma (map text mods)) <> text "."
569 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
571 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
574 typeOfExpr :: String -> GHCi ()
576 = do st <- getGHCiState
577 dflags <- io getDynFlags
578 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
579 setGHCiState st{cmstate = new_cmstate}
582 Just tystr -> io (putStrLn tystr)
584 quit :: String -> GHCi Bool
587 shellEscape :: String -> GHCi Bool
588 shellEscape str = io (system str >> return False)
590 ----------------------------------------------------------------------------
593 -- set options in the interpreter. Syntax is exactly the same as the
594 -- ghc command line, except that certain options aren't available (-C,
597 -- This is pretty fragile: most options won't work as expected. ToDo:
598 -- figure out which ones & disallow them.
600 setCmd :: String -> GHCi ()
602 = do st <- getGHCiState
603 let opts = options st
604 io $ putStrLn (showSDoc (
605 text "options currently set: " <>
608 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
612 ("args":args) -> setArgs args
613 ("prog":prog) -> setProg prog
614 wds -> setOptions wds
618 setGHCiState st{ args = args }
622 setGHCiState st{ progname = prog }
624 io (hPutStrLn stderr "syntax: :set prog <progname>")
627 do -- first, deal with the GHCi opts (+s, +t, etc.)
628 let (plus_opts, minus_opts) = partition isPlus wds
629 mapM setOpt plus_opts
631 -- now, the GHC flags
632 pkgs_before <- io (readIORef v_Packages)
633 leftovers <- io (processArgs static_flags minus_opts [])
634 pkgs_after <- io (readIORef v_Packages)
636 -- update things if the users wants more packages
637 when (pkgs_before /= pkgs_after) $
638 newPackages (pkgs_after \\ pkgs_before)
640 -- then, dynamic flags
643 leftovers <- processArgs dynamic_flags leftovers []
646 if (not (null leftovers))
647 then throwDyn (CmdLineError ("unrecognised flags: " ++
652 unsetOptions :: String -> GHCi ()
654 = do -- first, deal with the GHCi opts (+s, +t, etc.)
656 (minus_opts, rest1) = partition isMinus opts
657 (plus_opts, rest2) = partition isPlus rest1
659 if (not (null rest2))
660 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
663 mapM unsetOpt plus_opts
665 -- can't do GHC flags for now
666 if (not (null minus_opts))
667 then throwDyn (CmdLineError "can't unset GHC command-line flags")
670 isMinus ('-':s) = True
673 isPlus ('+':s) = True
677 = case strToGHCiOpt str of
678 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
679 Just o -> setOption o
682 = case strToGHCiOpt str of
683 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
684 Just o -> unsetOption o
686 strToGHCiOpt :: String -> (Maybe GHCiOption)
687 strToGHCiOpt "s" = Just ShowTiming
688 strToGHCiOpt "t" = Just ShowType
689 strToGHCiOpt "r" = Just RevertCAFs
690 strToGHCiOpt _ = Nothing
692 optToStr :: GHCiOption -> String
693 optToStr ShowTiming = "s"
694 optToStr ShowType = "t"
695 optToStr RevertCAFs = "r"
697 newPackages new_pkgs = do
698 state <- getGHCiState
699 dflags <- io getDynFlags
700 cmstate1 <- io (cmUnload (cmstate state) dflags)
701 setGHCiState state{ cmstate = cmstate1, targets = [] }
704 pkgs <- getPackageInfo
705 flushPackageCache pkgs
707 new_pkg_info <- getPackageDetails new_pkgs
708 mapM_ linkPackage (reverse new_pkg_info)
710 -----------------------------------------------------------------------------
713 data GHCiState = GHCiState
717 targets :: [FilePath],
719 options :: [GHCiOption]
723 = ShowTiming -- show time/allocs after evaluation
724 | ShowType -- show the type of expressions
725 | RevertCAFs -- revert CAFs after every evaluation
728 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
729 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
731 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
733 startGHCi :: GHCi a -> GHCiState -> IO a
734 startGHCi g state = do ref <- newIORef state; unGHCi g ref
736 instance Monad GHCi where
737 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
738 return a = GHCi $ \s -> return a
740 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
741 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
742 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
744 getGHCiState = GHCi $ \r -> readIORef r
745 setGHCiState s = GHCi $ \r -> writeIORef r s
747 isOptionSet :: GHCiOption -> GHCi Bool
749 = do st <- getGHCiState
750 return (opt `elem` options st)
752 setOption :: GHCiOption -> GHCi ()
754 = do st <- getGHCiState
755 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
757 unsetOption :: GHCiOption -> GHCi ()
759 = do st <- getGHCiState
760 setGHCiState (st{ options = filter (/= opt) (options st) })
763 io m = GHCi { unGHCi = \s -> m >>= return }
765 -----------------------------------------------------------------------------
766 -- recursive exception handlers
768 -- Don't forget to unblock async exceptions in the handler, or if we're
769 -- in an exception loop (eg. let a = error a in a) the ^C exception
770 -- may never be delivered. Thanks to Marcin for pointing out the bug.
772 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
773 ghciHandle h (GHCi m) = GHCi $ \s ->
774 Exception.catch (m s)
775 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
777 ghciUnblock :: GHCi a -> GHCi a
778 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
780 -----------------------------------------------------------------------------
783 -- Left: full path name of a .o file, including trailing .o
784 -- Right: "unadorned" name of a .DLL/.so
785 -- e.g. On unix "qt" denotes "libqt.so"
786 -- On WinDoze "burble" denotes "burble.DLL"
787 -- addDLL is platform-specific and adds the lib/.so/.DLL
788 -- suffixes platform-dependently; we don't do that here.
790 -- For dynamic objects only, try to find the object file in all the
791 -- directories specified in v_Library_Paths before giving up.
794 = Either FilePath String
796 showLS (Left nm) = "(static) " ++ nm
797 showLS (Right nm) = "(dynamic) " ++ nm
799 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
800 linkPackages cmdline_lib_specs pkgs
801 = do mapM_ linkPackage (reverse pkgs)
802 lib_paths <- readIORef v_Library_paths
803 mapM_ (preloadLib lib_paths) cmdline_lib_specs
804 if (null cmdline_lib_specs)
806 else do putStr "final link ... "
808 if ok then putStrLn "done."
809 else throwDyn (InstallationError "linking extra libraries/objects failed")
811 preloadLib :: [String] -> LibrarySpec -> IO ()
812 preloadLib lib_paths lib_spec
813 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
816 -> do b <- preload_static lib_paths static_ish
817 putStrLn (if b then "done." else "not found")
819 -> -- We add "" to the set of paths to try, so that
820 -- if none of the real paths match, we force addDLL
821 -- to look in the default dynamic-link search paths.
822 do b <- preload_dynamic (lib_paths++[""]) dll_unadorned
823 when (not b) (cantFind lib_paths lib_spec)
826 cantFind :: [String] -> LibrarySpec -> IO ()
828 = do putStr ("failed.\nCan't find " ++ showLS spec
829 ++ " in directories:\n"
830 ++ unlines (map (" "++) paths) )
833 -- not interested in the paths in the static case.
834 preload_static paths name
835 = do b <- doesFileExist name
836 if not b then return False
837 else loadObj name >> return True
839 preload_dynamic [] name
841 preload_dynamic (path:paths) rootname
842 = do maybe_errmsg <- addDLL path rootname
843 if maybe_errmsg /= nullPtr
844 then preload_dynamic paths rootname
848 = (throwDyn . CmdLineError)
849 "user specified .o/.so/.DLL could not be loaded."
851 -- Packages that don't need loading, because the compiler shares them with
852 -- the interpreted program.
853 dont_load_these = [ "gmp", "rts" ]
855 -- Packages that are already linked into GHCi. For mingw32, we only
856 -- skip gmp and rts, since std and after need to load the msvcrt.dll
857 -- library which std depends on.
859 # ifndef mingw32_TARGET_OS
860 = [ "std", "concurrent", "posix", "text", "util" ]
865 linkPackage :: PackageConfig -> IO ()
867 | name pkg `elem` dont_load_these = return ()
870 -- For each obj, try obj.o and if that fails, obj.so.
871 -- Complication: all the .so's must be loaded before any of the .o's.
872 let dirs = library_dirs pkg
873 let objs = hs_libraries pkg ++ extra_libraries pkg
874 classifieds <- mapM (locateOneObj dirs) objs
876 -- Don't load the .so libs if this is a package GHCi is already
877 -- linked against, because we'll already have the .so linked in.
878 let (so_libs, obj_libs) = partition isRight classifieds
879 let sos_first | name pkg `elem` loaded_in_ghci = obj_libs
880 | otherwise = so_libs ++ obj_libs
882 putStr ("Loading package " ++ name pkg ++ " ... ")
883 mapM loadClassified sos_first
884 putStr "linking ... "
886 if ok then putStrLn "done."
887 else panic ("can't load package `" ++ name pkg ++ "'")
889 isRight (Right _) = True
890 isRight (Left _) = False
892 loadClassified :: LibrarySpec -> IO ()
893 loadClassified (Left obj_absolute_filename)
894 = do loadObj obj_absolute_filename
895 loadClassified (Right dll_unadorned)
896 = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
897 if maybe_errmsg == nullPtr
899 else do str <- peekCString maybe_errmsg
900 throwDyn (CmdLineError ("can't load .so/.DLL for: "
901 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
903 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
905 = return (Right obj) -- we assume
906 locateOneObj (d:ds) obj
907 = do let path = d ++ '/':obj ++ ".o"
908 b <- doesFileExist path
909 if b then return (Left path) else locateOneObj ds obj
911 -----------------------------------------------------------------------------
912 -- timing & statistics
914 timeIt :: GHCi a -> GHCi a
916 = do b <- isOptionSet ShowTiming
919 else do allocs1 <- io $ getAllocations
920 time1 <- io $ getCPUTime
922 allocs2 <- io $ getAllocations
923 time2 <- io $ getCPUTime
924 io $ printTimes (allocs2 - allocs1) (time2 - time1)
927 foreign import "getAllocations" getAllocations :: IO Int
929 printTimes :: Int -> Integer -> IO ()
930 printTimes allocs psecs
931 = do let secs = (fromIntegral psecs / (10^12)) :: Float
932 secs_str = showFFloat (Just 2) secs
934 parens (text (secs_str "") <+> text "secs" <> comma <+>
935 int allocs <+> text "bytes")))
937 -----------------------------------------------------------------------------
940 foreign import revertCAFs :: IO () -- make it "safe", just in case