ghc/compiler/ghci/InteractiveUI.hs

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