ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.56 2001/03/23 12:12:18 simonmar Exp $
   3 --
   4 -- GHC Interactive User Interface
   5 --
   6 -- (c) The GHC Team 2000
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 {-# OPTIONS -#include "Linker.h" #-}
  11 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
  12
  13 #include "HsVersions.h"
  14
  15 import CompManager
  16 import CmStaticInfo
  17 import ByteCodeLink
  18 import DriverFlags
  19 import DriverState
  20 import DriverUtil
  21 import Linker
  22 import Util
  23 import Name             ( Name )
  24 import Outputable
  25 import Panic            ( GhcException(..) )
  26 import Config
  27
  28 import Exception
  29 import Dynamic
  30 #ifndef NO_READLINE
  31 import Readline
  32 #endif
  33 import IOExts
  34
  35 import Numeric
  36 import List
  37 import System
  38 import CPUTime
  39 import Directory
  40 import IO
  41 import Char
  42 import Monad            ( when )
  43
  44 import PrelGHC          ( unsafeCoerce# )
  45 import Foreign          ( nullPtr )
  46 import CString          ( peekCString )
  47
  48 -----------------------------------------------------------------------------
  49
  50 ghciWelcomeMsg = "\
  51 \   ___         ___ _\n\
  52 \  / _ \\ /\\  /\\/ __(_)\n\
  53 \ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", For Haskell 98.\n\
  54 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\
  55 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  56
  57 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  58
  59 builtin_commands :: [(String, String -> GHCi Bool)]
  60 builtin_commands = [
  61   ("add",       keepGoing addModule),
  62   ("cd",        keepGoing changeDirectory),
  63   ("def",       keepGoing defineMacro),
  64   ("help",      keepGoing help),
  65   ("?",         keepGoing help),
  66   ("load",      keepGoing loadModule),
  67   ("module",    keepGoing setContext),
  68   ("reload",    keepGoing reloadModule),
  69   ("set",       keepGoing setOptions),
  70   ("type",      keepGoing typeOfExpr),
  71   ("unset",     keepGoing unsetOptions),
  72   ("undef",     keepGoing undefineMacro),
  73   ("quit",      quit)
  74   ]
  75
  76 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
  77 keepGoing a str = a str >> return False
  78
  79 shortHelpText = "use :? for help.\n"
  80
  81 helpText = "\
  82 \ Commands available from the prompt:\n\
  83 \\
  84 \   <stmt>              evaluate/run <stmt>\n\
  85 \   :cd <dir>           change directory to <dir>\n\
  86 \   :def <cmd> <expr>   define a macro :<cmd>\n\
  87 \   :help, :?           display this list of commands\n\
  88 \   :load <filename>    load a module (and it dependents)\n\
  89 \   :module <mod>       set the context for expression evaluation to <mod>\n\
  90 \   :reload             reload the current module set\n\
  91 \   :set <option> ...   set options\n\
  92 \   :type <expr>        show the type of <expr>\n\
  93 \   :unset <option> ... unset options\n\
  94 \   :quit               exit GHCi\n\
  95 \   :!<command>         run the shell command <command>\n\
  96 \\
  97 \ Options for `:set' and `:unset':\n\
  98 \\
  99 \    +r                 revert top-level expressions after each evaluation\n\
 100 \    +s                 print timing/memory stats after each evaluation\n\
 101 \    +t                 print type after evaluation\n\
 102 \    -<flags>           most GHC command line flags can also be set here\n\
 103 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 104 \"
 105  --ToDo   :add <filename>     add a module to the current set\n\
 106
 107 interactiveUI :: CmState -> Maybe FilePath -> [LibrarySpec] -> IO ()
 108 interactiveUI cmstate mod cmdline_libs = do
 109    hFlush stdout
 110    hSetBuffering stdout NoBuffering
 111
 112    -- link in the available packages
 113    pkgs <- getPackageInfo
 114    initLinker
 115    linkPackages cmdline_libs (reverse pkgs)
 116
 117    (cmstate, ok, mods) <-
 118         case mod of
 119              Nothing  -> return (cmstate, True, [])
 120              Just m -> cmLoadModule cmstate m
 121
 122 #ifndef NO_READLINE
 123    Readline.initialize
 124 #endif
 125
 126    dflags <- getDynFlags
 127
 128    (cmstate, maybe_hval)
 129         <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
 130    case maybe_hval of
 131         Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
 132         _ -> panic "interactiveUI:stderr"
 133
 134    (cmstate, maybe_hval)
 135         <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
 136    case maybe_hval of
 137         Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
 138         _ -> panic "interactiveUI:stdout"
 139
 140    (unGHCi runGHCi) GHCiState{ target = mod,
 141                                cmstate = cmstate,
 142                                options = [ShowTiming] }
 143    return ()
 144
 145
 146 runGHCi :: GHCi ()
 147 runGHCi = do
 148   -- read in ./.ghci
 149   dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode))
 150   case dot_ghci of
 151         Left e -> return ()
 152         Right hdl -> fileLoop hdl False
 153
 154   -- read in ~/.ghci
 155   home <- io (IO.try (getEnv "HOME"))
 156   case home of
 157    Left e  -> return ()
 158    Right dir -> do
 159         dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode))
 160         case dot_ghci of
 161            Left e -> return ()
 162            Right hdl -> fileLoop hdl False
 163
 164   -- read commands from stdin
 165 #ifndef NO_READLINE
 166   readlineLoop
 167 #else
 168   fileLoop stdin True
 169 #endif
 170
 171   -- and finally, exit
 172   io $ do putStrLn "Leaving GHCi."
 173
 174
 175 fileLoop :: Handle -> Bool -> GHCi ()
 176 fileLoop hdl prompt = do
 177    st <- getGHCiState
 178    mod <- io (cmGetContext (cmstate st))
 179    when prompt (io (hPutStr hdl (mod ++ "> ")))
 180    l <- io (IO.try (hGetLine hdl))
 181    case l of
 182         Left e | isEOFError e -> return ()
 183                | otherwise    -> throw e
 184         Right l ->
 185           case remove_spaces l of
 186             "" -> fileLoop hdl prompt
 187             l  -> do quit <- runCommand l
 188                      if quit then return () else fileLoop hdl prompt
 189
 190 stringLoop :: [String] -> GHCi ()
 191 stringLoop [] = return ()
 192 stringLoop (s:ss) = do
 193    st <- getGHCiState
 194    case remove_spaces s of
 195         "" -> stringLoop ss
 196         l  -> do quit <- runCommand l
 197                  if quit then return () else stringLoop ss
 198
 199 #ifndef NO_READLINE
 200 readlineLoop :: GHCi ()
 201 readlineLoop = do
 202    st <- getGHCiState
 203    mod <- io (cmGetContext (cmstate st))
 204    l <- io (readline (mod ++ "> "))
 205    case l of
 206         Nothing -> return ()
 207         Just l  ->
 208           case remove_spaces l of
 209             "" -> readlineLoop
 210             l  -> do
 211                   io (addHistory l)
 212                   quit <- runCommand l
 213                   if quit then return () else readlineLoop
 214 #endif
 215
 216 -- Top level exception handler, just prints out the exception
 217 -- and carries on.
 218 runCommand :: String -> GHCi Bool
 219 runCommand c =
 220   ghciHandle ( \exception ->
 221         (case exception of
 222            DynException dyn ->
 223               case fromDynamic dyn of
 224                 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
 225                 Just ghc_ex ->
 226                   case ghc_ex of
 227                     PhaseFailed phase code ->
 228                         io ( putStrLn ("Phase " ++ phase ++ " failed (code "
 229                                         ++ show code ++ ")"))
 230                     Interrupted -> io (putStrLn "Interrupted.")
 231                     other -> io (putStrLn (show (ghc_ex :: GhcException)))
 232
 233            other -> io (putStrLn ("*** Exception: " ++ show exception))
 234
 235         ) >> return False
 236      ) $
 237
 238    doCommand c
 239
 240 doCommand (':' : command) = specialCommand command
 241 doCommand stmt
 242    = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff)
 243         return False
 244
 245 -- Returns True if the expr was successfully parsed, renamed and
 246 -- typechecked.
 247 runStmt :: String -> GHCi (Maybe [Name])
 248 runStmt stmt
 249  | null (filter (not.isSpace) stmt)
 250  = return Nothing
 251  | otherwise
 252  = do st <- getGHCiState
 253       dflags <- io (getDynFlags)
 254       (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags stmt)
 255       setGHCiState st{cmstate = new_cmstate}
 256       return (Just names)
 257
 258 -- possibly print the type and revert CAFs after evaluating an expression
 259 finishEvalExpr Nothing = return False
 260 finishEvalExpr (Just names)
 261  = do b <- isOptionSet ShowType
 262       st <- getGHCiState
 263       when b (mapM_ (showTypeOfName (cmstate st)) names)
 264
 265       b <- isOptionSet RevertCAFs
 266       io (when b revertCAFs)
 267       flushEverything
 268       return True
 269
 270 showTypeOfName :: CmState -> Name -> GHCi ()
 271 showTypeOfName cmstate n
 272    = do maybe_str <- io (cmTypeOfName cmstate n)
 273         case maybe_str of
 274           Nothing  -> return ()
 275           Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
 276
 277 flushEverything :: GHCi ()
 278 flushEverything
 279    = io $ do flush_so <- readIORef flush_stdout
 280              flush_so
 281              flush_se <- readIORef flush_stdout
 282              flush_se
 283              return ()
 284
 285 specialCommand :: String -> GHCi Bool
 286 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 287 specialCommand str = do
 288   let (cmd,rest) = break isSpace str
 289   cmds <- io (readIORef commands)
 290   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 291      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 292                                     ++ shortHelpText) >> return False)
 293      [(_,f)] -> f (dropWhile isSpace rest)
 294      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 295                                       " matches multiple commands (" ++
 296                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 297                                          ++ ")") >> return False)
 298
 299 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
 300
 301 -----------------------------------------------------------------------------
 302 -- Commands
 303
 304 help :: String -> GHCi ()
 305 help _ = io (putStr helpText)
 306
 307 addModule :: String -> GHCi ()
 308 addModule _ = throwDyn (OtherError ":add not implemented")
 309
 310 setContext :: String -> GHCi ()
 311 setContext ""
 312   = throwDyn (OtherError "syntax: `:m <module>'")
 313 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
 314   = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
 315 setContext str
 316   = do st <- getGHCiState
 317        new_cmstate <- io (cmSetContext (cmstate st) str)
 318        setGHCiState st{cmstate=new_cmstate}
 319
 320 changeDirectory :: String -> GHCi ()
 321 changeDirectory ('~':d) = do
 322    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
 323    io (setCurrentDirectory (tilde ++ '/':d))
 324 changeDirectory d = io (setCurrentDirectory d)
 325
 326 defineMacro :: String -> GHCi ()
 327 defineMacro s = do
 328   let (macro_name, definition) = break isSpace s
 329   cmds <- io (readIORef commands)
 330   if (null macro_name)
 331         then throwDyn (OtherError "invalid macro name")
 332         else do
 333   if (macro_name `elem` map fst cmds)
 334         then throwDyn (OtherError
 335                 ("command `" ++ macro_name ++ "' is already defined"))
 336         else do
 337
 338   -- give the expression a type signature, so we can be sure we're getting
 339   -- something of the right type.
 340   let new_expr = '(' : definition ++ ") :: String -> IO String"
 341
 342   -- compile the expression
 343   st <- getGHCiState
 344   dflags <- io (getDynFlags)
 345   (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
 346   setGHCiState st{cmstate = new_cmstate}
 347   case maybe_hv of
 348      Nothing -> return ()
 349      Just hv -> io (writeIORef commands --
 350                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 351
 352 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 353 runMacro fun s = do
 354   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 355   stringLoop (lines str)
 356
 357 undefineMacro :: String -> GHCi ()
 358 undefineMacro macro_name = do
 359   cmds <- io (readIORef commands)
 360   if (macro_name `elem` map fst builtin_commands)
 361         then throwDyn (OtherError
 362                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 363         else do
 364   if (macro_name `notElem` map fst cmds)
 365         then throwDyn (OtherError
 366                 ("command `" ++ macro_name ++ "' not defined"))
 367         else do
 368   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 369
 370 loadModule :: String -> GHCi ()
 371 loadModule path = timeIt (loadModule' path)
 372
 373 loadModule' path = do
 374   state <- getGHCiState
 375   cmstate1 <- io (cmUnload (cmstate state))
 376   io (revertCAFs)                       -- always revert CAFs on load.
 377   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
 378   let new_state = state{ cmstate = cmstate2,
 379                          target = Just path
 380                        }
 381   setGHCiState new_state
 382   modulesLoadedMsg ok mods
 383
 384 reloadModule :: String -> GHCi ()
 385 reloadModule "" = do
 386   state <- getGHCiState
 387   case target state of
 388    Nothing -> io (putStr "no current target\n")
 389    Just path
 390       -> do io (revertCAFs)             -- always revert CAFs on reload.
 391             (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
 392             setGHCiState state{ cmstate=new_cmstate }
 393             modulesLoadedMsg ok mods
 394
 395 reloadModule _ = noArgs ":reload"
 396
 397
 398 modulesLoadedMsg ok mods = do
 399   let mod_commas
 400         | null mods = text "none."
 401         | otherwise = hsep (
 402             punctuate comma (map text mods)) <> text "."
 403   case ok of
 404     False ->
 405        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 406     True  ->
 407        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 408
 409
 410 typeOfExpr :: String -> GHCi ()
 411 typeOfExpr str
 412   = do st <- getGHCiState
 413        dflags <- io (getDynFlags)
 414        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
 415        setGHCiState st{cmstate = new_cmstate}
 416        case maybe_tystr of
 417           Nothing    -> return ()
 418           Just tystr -> io (putStrLn tystr)
 419
 420 quit :: String -> GHCi Bool
 421 quit _ = return True
 422
 423 shellEscape :: String -> GHCi Bool
 424 shellEscape str = io (system str >> return False)
 425
 426 ----------------------------------------------------------------------------
 427 -- Code for `:set'
 428
 429 -- set options in the interpreter.  Syntax is exactly the same as the
 430 -- ghc command line, except that certain options aren't available (-C,
 431 -- -E etc.)
 432 --
 433 -- This is pretty fragile: most options won't work as expected.  ToDo:
 434 -- figure out which ones & disallow them.
 435
 436 setOptions :: String -> GHCi ()
 437 setOptions ""
 438   = do st <- getGHCiState
 439        let opts = options st
 440        io $ putStrLn (showSDoc (
 441               text "options currently set: " <>
 442               if null opts
 443                    then text "none."
 444                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 445            ))
 446 setOptions str
 447   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 448        let opts = words str
 449            (minus_opts, rest1) = partition isMinus opts
 450            (plus_opts, rest2)  = partition isPlus rest1
 451
 452        if (not (null rest2))
 453           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 454           else do
 455
 456        mapM setOpt plus_opts
 457
 458        -- now, the GHC flags
 459        io (do -- first, static flags
 460               leftovers <- processArgs static_flags minus_opts []
 461
 462               -- then, dynamic flags
 463               dyn_flags <- readIORef v_InitDynFlags
 464               writeIORef v_DynFlags dyn_flags
 465               leftovers <- processArgs dynamic_flags leftovers []
 466               dyn_flags <- readIORef v_DynFlags
 467               writeIORef v_InitDynFlags dyn_flags
 468
 469               if (not (null leftovers))
 470                  then throwDyn (OtherError ("unrecognised flags: " ++
 471                                                 unwords leftovers))
 472                  else return ()
 473          )
 474
 475 unsetOptions :: String -> GHCi ()
 476 unsetOptions str
 477   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 478        let opts = words str
 479            (minus_opts, rest1) = partition isMinus opts
 480            (plus_opts, rest2)  = partition isPlus rest1
 481
 482        if (not (null rest2))
 483           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 484           else do
 485
 486        mapM unsetOpt plus_opts
 487
 488        -- can't do GHC flags for now
 489        if (not (null minus_opts))
 490           then throwDyn (OtherError "can't unset GHC command-line flags")
 491           else return ()
 492
 493 isMinus ('-':s) = True
 494 isMinus _ = False
 495
 496 isPlus ('+':s) = True
 497 isPlus _ = False
 498
 499 setOpt ('+':str)
 500   = case strToGHCiOpt str of
 501         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 502         Just o  -> setOption o
 503
 504 unsetOpt ('+':str)
 505   = case strToGHCiOpt str of
 506         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 507         Just o  -> unsetOption o
 508
 509 strToGHCiOpt :: String -> (Maybe GHCiOption)
 510 strToGHCiOpt "s" = Just ShowTiming
 511 strToGHCiOpt "t" = Just ShowType
 512 strToGHCiOpt "r" = Just RevertCAFs
 513 strToGHCiOpt _   = Nothing
 514
 515 optToStr :: GHCiOption -> String
 516 optToStr ShowTiming = "s"
 517 optToStr ShowType   = "t"
 518 optToStr RevertCAFs = "r"
 519
 520 -----------------------------------------------------------------------------
 521 -- GHCi monad
 522
 523 data GHCiState = GHCiState
 524      {
 525         target         :: Maybe FilePath,
 526         cmstate        :: CmState,
 527         options        :: [GHCiOption]
 528      }
 529
 530 data GHCiOption
 531         = ShowTiming            -- show time/allocs after evaluation
 532         | ShowType              -- show the type of expressions
 533         | RevertCAFs            -- revert CAFs after every evaluation
 534         deriving Eq
 535
 536 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
 537 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
 538
 539 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 540
 541 instance Monad GHCi where
 542   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 543   return a  = GHCi $ \s -> return (s,a)
 544
 545 getGHCiState   = GHCi $ \s -> return (s,s)
 546 setGHCiState s = GHCi $ \_ -> return (s,())
 547
 548 isOptionSet :: GHCiOption -> GHCi Bool
 549 isOptionSet opt
 550  = do st <- getGHCiState
 551       return (opt `elem` options st)
 552
 553 setOption :: GHCiOption -> GHCi ()
 554 setOption opt
 555  = do st <- getGHCiState
 556       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 557
 558 unsetOption :: GHCiOption -> GHCi ()
 559 unsetOption opt
 560  = do st <- getGHCiState
 561       setGHCiState (st{ options = filter (/= opt) (options st) })
 562
 563 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 564
 565 -----------------------------------------------------------------------------
 566 -- recursive exception handlers
 567
 568 -- Don't forget to unblock async exceptions in the handler, or if we're
 569 -- in an exception loop (eg. let a = error a in a) the ^C exception
 570 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 571
 572 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 573 ghciHandle h (GHCi m) = GHCi $ \s ->
 574    Exception.catch (m s)
 575         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 576
 577 ghciUnblock :: GHCi a -> GHCi a
 578 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 579
 580 -----------------------------------------------------------------------------
 581 -- package loader
 582
 583 -- Left: full path name of a .o file, including trailing .o
 584 -- Right: "unadorned" name of a .DLL/.so
 585 --        e.g.    On unix     "qt"  denotes "libqt.so"
 586 --                On WinDoze  "burble"  denotes "burble.DLL"
 587 --        addDLL is platform-specific and adds the lib/.so/.DLL
 588 --        prefixes plaform-dependently; we don't do that here.
 589 type LibrarySpec
 590    = Either FilePath String
 591
 592 showLS (Left nm)  = "(static) " ++ nm
 593 showLS (Right nm) = "(dynamic) " ++ nm
 594
 595 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
 596 linkPackages cmdline_lib_specs pkgs
 597    = do mapM_ linkPackage pkgs
 598         mapM_ preloadLib cmdline_lib_specs
 599      where
 600         preloadLib lib_spec
 601            = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
 602                 case lib_spec of
 603                    Left static_ish
 604                       -> do b <- doesFileExist static_ish
 605                             if    not b
 606                              then do putStr "not found.\n"
 607                                      croak
 608                              else do loadObj static_ish
 609                                      putStr "done.\n"
 610                    Right dll_unadorned
 611                       -> do maybe_errmsg <- addDLL dll_unadorned
 612                             if    maybe_errmsg == nullPtr
 613                              then putStr "done.\n"
 614                              else do str <- peekCString maybe_errmsg
 615                                      putStr ("failed (" ++ str ++ ")\n")
 616                                      croak
 617
 618         croak = throwDyn (OtherError "user specified .o/.so/.DLL could not be loaded.")
 619
 620
 621 linkPackage :: PackageConfig -> IO ()
 622 -- ignore rts and gmp for now (ToDo; better?)
 623 linkPackage pkg
 624    | name pkg `elem` ["rts", "gmp"]
 625    = return ()
 626    | otherwise
 627    = do putStr ("Loading package " ++ name pkg ++ " ... ")
 628         -- For each obj, try obj.o and if that fails, obj.so.
 629         -- Complication: all the .so's must be loaded before any of the .o's.
 630         let dirs      =  library_dirs pkg
 631         let objs      =  hs_libraries pkg ++ extra_libraries pkg
 632         classifieds   <- mapM (locateOneObj dirs) objs
 633         let sos_first = filter isRight classifieds
 634                         ++ filter (not.isRight) classifieds
 635         mapM loadClassified sos_first
 636         putStr "linking ... "
 637         resolveObjs
 638         putStrLn "done."
 639      where
 640         isRight (Right _) = True
 641         isRight (Left _)  = False
 642
 643 loadClassified :: LibrarySpec -> IO ()
 644 loadClassified (Left obj_absolute_filename)
 645    = do loadObj obj_absolute_filename
 646 loadClassified (Right dll_unadorned)
 647    = do maybe_errmsg <- addDLL dll_unadorned
 648         if    maybe_errmsg == nullPtr
 649          then return ()
 650          else do str <- peekCString maybe_errmsg
 651                  throwDyn (OtherError ("can't find .o or .so/.DLL for: "
 652                                        ++ dll_unadorned ++ " (" ++ str ++ ")" ))
 653
 654 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
 655 locateOneObj []     obj
 656    = return (Right obj) -- we assume
 657 locateOneObj (d:ds) obj
 658    = do let path = d ++ '/':obj ++ ".o"
 659         b <- doesFileExist path
 660         if b then return (Left path) else locateOneObj ds obj
 661
 662 -----------------------------------------------------------------------------
 663 -- timing & statistics
 664
 665 timeIt :: GHCi a -> GHCi a
 666 timeIt action
 667   = do b <- isOptionSet ShowTiming
 668        if not b
 669           then action
 670           else do allocs1 <- io $ getAllocations
 671                   time1   <- io $ getCPUTime
 672                   a <- action
 673                   allocs2 <- io $ getAllocations
 674                   time2   <- io $ getCPUTime
 675                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 676                   return a
 677
 678 foreign import "getAllocations" getAllocations :: IO Int
 679
 680 printTimes :: Int -> Integer -> IO ()
 681 printTimes allocs psecs
 682    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 683             secs_str = showFFloat (Just 2) secs
 684         putStrLn (showSDoc (
 685                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 686                          int allocs <+> text "bytes")))
 687
 688 -----------------------------------------------------------------------------
 689 -- reverting CAFs
 690
 691 foreign import revertCAFs :: IO ()      -- make it "safe", just in case