ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.54 2001/03/12 14:06:46 simonpj 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 \   :add <filename>     add a module to the current set\n\
  86 \   :cd <dir>           change directory to <dir>\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 \   :unset <option> ... unset options\n\
  93 \   :type <expr>        show the type of <expr>\n\
  94 \   :quit               exit GHCi\n\
  95 \   :!<command>         run the shell command <command>\n\
  96 \\
  97 \ Options for `:set' and `:unset':\n\
  98 \\
  99 \    +s                 print timing/memory stats after each evaluation\n\
 100 \    +t                 print type after evaluation\n\
 101 \    +r                 revert top-level expressions after each evaluation\n\
 102 \    -<flags>           most GHC command line flags can also be set here\n\
 103 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 104 \"
 105
 106 interactiveUI :: CmState -> Maybe FilePath -> [LibrarySpec] -> IO ()
 107 interactiveUI cmstate mod cmdline_libs = do
 108    hFlush stdout
 109    hSetBuffering stdout NoBuffering
 110
 111    -- link in the available packages
 112    pkgs <- getPackageInfo
 113    initLinker
 114    linkPackages cmdline_libs (reverse pkgs)
 115
 116    (cmstate, ok, mods) <-
 117         case mod of
 118              Nothing  -> return (cmstate, True, [])
 119              Just m -> cmLoadModule cmstate m
 120
 121 #ifndef NO_READLINE
 122    Readline.initialize
 123 #endif
 124
 125    dflags <- getDynFlags
 126
 127    (cmstate, maybe_hval)
 128         <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
 129    case maybe_hval of
 130         Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
 131         _ -> panic "interactiveUI:stderr"
 132
 133    (cmstate, maybe_hval)
 134         <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
 135    case maybe_hval of
 136         Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
 137         _ -> panic "interactiveUI:stdout"
 138
 139    (unGHCi runGHCi) GHCiState{ target = mod,
 140                                cmstate = cmstate,
 141                                options = [ShowTiming] }
 142    return ()
 143
 144
 145 runGHCi :: GHCi ()
 146 runGHCi = do
 147   -- read in ./.ghci
 148   dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode))
 149   case dot_ghci of
 150         Left e -> return ()
 151         Right hdl -> fileLoop hdl False
 152
 153   -- read in ~/.ghci
 154   home <- io (IO.try (getEnv "HOME"))
 155   case home of
 156    Left e  -> return ()
 157    Right dir -> do
 158         dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode))
 159         case dot_ghci of
 160            Left e -> return ()
 161            Right hdl -> fileLoop hdl False
 162
 163   -- read commands from stdin
 164 #ifndef NO_READLINE
 165   readlineLoop
 166 #else
 167   fileLoop stdin True
 168 #endif
 169
 170   -- and finally, exit
 171   io $ do putStrLn "Leaving GHCi."
 172
 173
 174 fileLoop :: Handle -> Bool -> GHCi ()
 175 fileLoop hdl prompt = do
 176    st <- getGHCiState
 177    mod <- io (cmGetContext (cmstate st))
 178    when prompt (io (hPutStr hdl (mod ++ "> ")))
 179    l <- io (IO.try (hGetLine hdl))
 180    case l of
 181         Left e | isEOFError e -> return ()
 182                | otherwise    -> throw e
 183         Right l ->
 184           case remove_spaces l of
 185             "" -> fileLoop hdl prompt
 186             l  -> do quit <- runCommand l
 187                      if quit then return () else fileLoop hdl prompt
 188
 189 stringLoop :: [String] -> GHCi ()
 190 stringLoop [] = return ()
 191 stringLoop (s:ss) = do
 192    st <- getGHCiState
 193    case remove_spaces s of
 194         "" -> stringLoop ss
 195         l  -> do quit <- runCommand l
 196                  if quit then return () else stringLoop ss
 197
 198 #ifndef NO_READLINE
 199 readlineLoop :: GHCi ()
 200 readlineLoop = do
 201    st <- getGHCiState
 202    mod <- io (cmGetContext (cmstate st))
 203    l <- io (readline (mod ++ "> "))
 204    case l of
 205         Nothing -> return ()
 206         Just l  ->
 207           case remove_spaces l of
 208             "" -> readlineLoop
 209             l  -> do
 210                   io (addHistory l)
 211                   quit <- runCommand l
 212                   if quit then return () else readlineLoop
 213 #endif
 214
 215 -- Top level exception handler, just prints out the exception
 216 -- and carries on.
 217 runCommand :: String -> GHCi Bool
 218 runCommand c =
 219   ghciHandle ( \exception ->
 220         (case exception of
 221            DynException dyn ->
 222               case fromDynamic dyn of
 223                 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
 224                 Just ghc_ex ->
 225                   case ghc_ex of
 226                     PhaseFailed phase code ->
 227                         io ( putStrLn ("Phase " ++ phase ++ " failed (code "
 228                                         ++ show code ++ ")"))
 229                     Interrupted -> io (putStrLn "Interrupted.")
 230                     other -> io (putStrLn (show (ghc_ex :: GhcException)))
 231
 232            other -> io (putStrLn ("*** Exception: " ++ show exception))
 233
 234         ) >> return False
 235      ) $
 236
 237    doCommand c
 238
 239 doCommand (':' : command) = specialCommand command
 240 doCommand ('-':'-':_) = return False    -- comments, useful in scripts
 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 = io (setCurrentDirectory d)
 322
 323 defineMacro :: String -> GHCi ()
 324 defineMacro s = do
 325   let (macro_name, definition) = break isSpace s
 326   cmds <- io (readIORef commands)
 327   if (null macro_name)
 328         then throwDyn (OtherError "invalid macro name")
 329         else do
 330   if (macro_name `elem` map fst cmds)
 331         then throwDyn (OtherError
 332                 ("command `" ++ macro_name ++ "' is already defined"))
 333         else do
 334
 335   -- give the expression a type signature, so we can be sure we're getting
 336   -- something of the right type.
 337   let new_expr = '(' : definition ++ ") :: String -> IO String"
 338
 339   -- compile the expression
 340   st <- getGHCiState
 341   dflags <- io (getDynFlags)
 342   (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
 343   setGHCiState st{cmstate = new_cmstate}
 344   case maybe_hv of
 345         Nothing -> return ()
 346         Just hv ->
 347           do funs <- io (unsafeCoerce# hv :: IO [HValue])
 348              case funs of
 349                 [fun] -> io (writeIORef commands
 350                                 ((macro_name, keepGoing (runMacro fun))
 351                                  : cmds))
 352                 _ -> throwDyn (OtherError "defineMacro: bizarre")
 353
 354 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 355 runMacro fun s = do
 356   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 357   stringLoop (lines str)
 358
 359 undefineMacro :: String -> GHCi ()
 360 undefineMacro macro_name = do
 361   cmds <- io (readIORef commands)
 362   if (macro_name `elem` map fst builtin_commands)
 363         then throwDyn (OtherError
 364                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 365         else do
 366   if (macro_name `notElem` map fst cmds)
 367         then throwDyn (OtherError
 368                 ("command `" ++ macro_name ++ "' not defined"))
 369         else do
 370   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 371
 372 loadModule :: String -> GHCi ()
 373 loadModule path = timeIt (loadModule' path)
 374
 375 loadModule' path = do
 376   state <- getGHCiState
 377   cmstate1 <- io (cmUnload (cmstate state))
 378   io (revertCAFs)                       -- always revert CAFs on load.
 379   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
 380   let new_state = state{ cmstate = cmstate2,
 381                          target = Just path
 382                        }
 383   setGHCiState new_state
 384   modulesLoadedMsg ok mods
 385
 386 reloadModule :: String -> GHCi ()
 387 reloadModule "" = do
 388   state <- getGHCiState
 389   case target state of
 390    Nothing -> io (putStr "no current target\n")
 391    Just path
 392       -> do io (revertCAFs)             -- always revert CAFs on reload.
 393             (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
 394             setGHCiState state{ cmstate=new_cmstate }
 395             modulesLoadedMsg ok mods
 396
 397 reloadModule _ = noArgs ":reload"
 398
 399
 400 modulesLoadedMsg ok mods = do
 401   let mod_commas
 402         | null mods = text "none."
 403         | otherwise = hsep (
 404             punctuate comma (map text mods)) <> text "."
 405   case ok of
 406     False ->
 407        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 408     True  ->
 409        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 410
 411
 412 typeOfExpr :: String -> GHCi ()
 413 typeOfExpr str
 414   = do st <- getGHCiState
 415        dflags <- io (getDynFlags)
 416        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
 417        setGHCiState st{cmstate = new_cmstate}
 418        case maybe_tystr of
 419           Nothing    -> return ()
 420           Just tystr -> io (putStrLn tystr)
 421
 422 quit :: String -> GHCi Bool
 423 quit _ = return True
 424
 425 shellEscape :: String -> GHCi Bool
 426 shellEscape str = io (system str >> return False)
 427
 428 ----------------------------------------------------------------------------
 429 -- Code for `:set'
 430
 431 -- set options in the interpreter.  Syntax is exactly the same as the
 432 -- ghc command line, except that certain options aren't available (-C,
 433 -- -E etc.)
 434 --
 435 -- This is pretty fragile: most options won't work as expected.  ToDo:
 436 -- figure out which ones & disallow them.
 437
 438 setOptions :: String -> GHCi ()
 439 setOptions ""
 440   = do st <- getGHCiState
 441        let opts = options st
 442        io $ putStrLn (showSDoc (
 443               text "options currently set: " <>
 444               if null opts
 445                    then text "none."
 446                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 447            ))
 448 setOptions str
 449   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 450        let opts = words str
 451            (minus_opts, rest1) = partition isMinus opts
 452            (plus_opts, rest2)  = partition isPlus rest1
 453
 454        if (not (null rest2))
 455           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 456           else do
 457
 458        mapM setOpt plus_opts
 459
 460        -- now, the GHC flags
 461        io (do -- first, static flags
 462               leftovers <- processArgs static_flags minus_opts []
 463
 464               -- then, dynamic flags
 465               dyn_flags <- readIORef v_InitDynFlags
 466               writeIORef v_DynFlags dyn_flags
 467               leftovers <- processArgs dynamic_flags leftovers []
 468               dyn_flags <- readIORef v_DynFlags
 469               writeIORef v_InitDynFlags dyn_flags
 470
 471               if (not (null leftovers))
 472                  then throwDyn (OtherError ("unrecognised flags: " ++
 473                                                 unwords leftovers))
 474                  else return ()
 475          )
 476
 477 unsetOptions :: String -> GHCi ()
 478 unsetOptions str
 479   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 480        let opts = words str
 481            (minus_opts, rest1) = partition isMinus opts
 482            (plus_opts, rest2)  = partition isPlus rest1
 483
 484        if (not (null rest2))
 485           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 486           else do
 487
 488        mapM unsetOpt plus_opts
 489
 490        -- can't do GHC flags for now
 491        if (not (null minus_opts))
 492           then throwDyn (OtherError "can't unset GHC command-line flags")
 493           else return ()
 494
 495 isMinus ('-':s) = True
 496 isMinus _ = False
 497
 498 isPlus ('+':s) = True
 499 isPlus _ = False
 500
 501 setOpt ('+':str)
 502   = case strToGHCiOpt str of
 503         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 504         Just o  -> setOption o
 505
 506 unsetOpt ('+':str)
 507   = case strToGHCiOpt str of
 508         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 509         Just o  -> unsetOption o
 510
 511 strToGHCiOpt :: String -> (Maybe GHCiOption)
 512 strToGHCiOpt "s" = Just ShowTiming
 513 strToGHCiOpt "t" = Just ShowType
 514 strToGHCiOpt "r" = Just RevertCAFs
 515 strToGHCiOpt _   = Nothing
 516
 517 optToStr :: GHCiOption -> String
 518 optToStr ShowTiming = "s"
 519 optToStr ShowType   = "t"
 520 optToStr RevertCAFs = "r"
 521
 522 -----------------------------------------------------------------------------
 523 -- GHCi monad
 524
 525 data GHCiState = GHCiState
 526      {
 527         target         :: Maybe FilePath,
 528         cmstate        :: CmState,
 529         options        :: [GHCiOption]
 530      }
 531
 532 data GHCiOption
 533         = ShowTiming            -- show time/allocs after evaluation
 534         | ShowType              -- show the type of expressions
 535         | RevertCAFs            -- revert CAFs after every evaluation
 536         deriving Eq
 537
 538 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
 539 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
 540
 541 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 542
 543 instance Monad GHCi where
 544   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 545   return a  = GHCi $ \s -> return (s,a)
 546
 547 getGHCiState   = GHCi $ \s -> return (s,s)
 548 setGHCiState s = GHCi $ \_ -> return (s,())
 549
 550 isOptionSet :: GHCiOption -> GHCi Bool
 551 isOptionSet opt
 552  = do st <- getGHCiState
 553       return (opt `elem` options st)
 554
 555 setOption :: GHCiOption -> GHCi ()
 556 setOption opt
 557  = do st <- getGHCiState
 558       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 559
 560 unsetOption :: GHCiOption -> GHCi ()
 561 unsetOption opt
 562  = do st <- getGHCiState
 563       setGHCiState (st{ options = filter (/= opt) (options st) })
 564
 565 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 566
 567 -----------------------------------------------------------------------------
 568 -- recursive exception handlers
 569
 570 -- Don't forget to unblock async exceptions in the handler, or if we're
 571 -- in an exception loop (eg. let a = error a in a) the ^C exception
 572 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 573
 574 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 575 ghciHandle h (GHCi m) = GHCi $ \s ->
 576    Exception.catch (m s)
 577         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 578
 579 ghciUnblock :: GHCi a -> GHCi a
 580 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 581
 582 -----------------------------------------------------------------------------
 583 -- package loader
 584
 585 -- Left: full path name of a .o file, including trailing .o
 586 -- Right: "unadorned" name of a .DLL/.so
 587 --        e.g.    On unix     "qt"  denotes "libqt.so"
 588 --                On WinDoze  "burble"  denotes "burble.DLL"
 589 --        addDLL is platform-specific and adds the lib/.so/.DLL
 590 --        prefixes plaform-dependently; we don't do that here.
 591 type LibrarySpec
 592    = Either FilePath String
 593
 594 showLS (Left nm)  = "(static) " ++ nm
 595 showLS (Right nm) = "(dynamic) " ++ nm
 596
 597 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
 598 linkPackages cmdline_lib_specs pkgs
 599    = do mapM_ linkPackage pkgs
 600         mapM_ preloadLib cmdline_lib_specs
 601      where
 602         preloadLib lib_spec
 603            = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
 604                 case lib_spec of
 605                    Left static_ish
 606                       -> do b <- doesFileExist static_ish
 607                             if    not b
 608                              then do putStr "not found.\n"
 609                                      croak
 610                              else do loadObj static_ish
 611                                      putStr "done.\n"
 612                    Right dll_unadorned
 613                       -> do maybe_errmsg <- addDLL dll_unadorned
 614                             if    maybe_errmsg == nullPtr
 615                              then putStr "done.\n"
 616                              else do str <- peekCString maybe_errmsg
 617                                      putStr ("failed (" ++ str ++ ")\n")
 618                                      croak
 619
 620         croak = throwDyn (OtherError "user specified .o/.so/.DLL could not be loaded.")
 621
 622
 623 linkPackage :: PackageConfig -> IO ()
 624 -- ignore rts and gmp for now (ToDo; better?)
 625 linkPackage pkg
 626    | name pkg `elem` ["rts", "gmp"]
 627    = return ()
 628    | otherwise
 629    = do putStr ("Loading package " ++ name pkg ++ " ... ")
 630         -- For each obj, try obj.o and if that fails, obj.so.
 631         -- Complication: all the .so's must be loaded before any of the .o's.
 632         let dirs      =  library_dirs pkg
 633         let objs      =  hs_libraries pkg ++ extra_libraries pkg
 634         classifieds   <- mapM (locateOneObj dirs) objs
 635         let sos_first = filter isRight classifieds
 636                         ++ filter (not.isRight) classifieds
 637         mapM loadClassified sos_first
 638         putStr "linking ... "
 639         resolveObjs
 640         putStrLn "done."
 641      where
 642         isRight (Right _) = True
 643         isRight (Left _)  = False
 644
 645 loadClassified :: LibrarySpec -> IO ()
 646 loadClassified (Left obj_absolute_filename)
 647    = do loadObj obj_absolute_filename
 648 loadClassified (Right dll_unadorned)
 649    = do maybe_errmsg <- addDLL dll_unadorned
 650         if    maybe_errmsg == nullPtr
 651          then return ()
 652          else do str <- peekCString maybe_errmsg
 653                  throwDyn (OtherError ("can't find .o or .so/.DLL for: "
 654                                        ++ dll_unadorned ++ " (" ++ str ++ ")" ))
 655
 656 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
 657 locateOneObj []     obj
 658    = return (Right obj) -- we assume
 659 locateOneObj (d:ds) obj
 660    = do let path = d ++ '/':obj ++ ".o"
 661         b <- doesFileExist path
 662         if b then return (Left path) else locateOneObj ds obj
 663
 664 -----------------------------------------------------------------------------
 665 -- timing & statistics
 666
 667 timeIt :: GHCi a -> GHCi a
 668 timeIt action
 669   = do b <- isOptionSet ShowTiming
 670        if not b
 671           then action
 672           else do allocs1 <- io $ getAllocations
 673                   time1   <- io $ getCPUTime
 674                   a <- action
 675                   allocs2 <- io $ getAllocations
 676                   time2   <- io $ getCPUTime
 677                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 678                   return a
 679
 680 foreign import "getAllocations" getAllocations :: IO Int
 681
 682 printTimes :: Int -> Integer -> IO ()
 683 printTimes allocs psecs
 684    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 685             secs_str = showFFloat (Just 2) secs
 686         putStrLn (showSDoc (
 687                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 688                          int allocs <+> text "bytes")))
 689
 690 -----------------------------------------------------------------------------
 691 -- reverting CAFs
 692
 693 foreign import revertCAFs :: IO ()      -- make it "safe", just in case