ghc/compiler/ghci/InteractiveUI.hs

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