ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.35 2001/02/08 14:58:28 simonmar Exp $
   3 --
   4 -- GHC Interactive User Interface
   5 --
   6 -- (c) The GHC Team 2000
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module InteractiveUI (interactiveUI) where
  11
  12 #include "HsVersions.h"
  13
  14 import CompManager
  15 import CmStaticInfo
  16 import ByteCodeLink
  17 import DriverFlags
  18 import DriverState
  19 import DriverUtil
  20 import Type
  21 import Linker
  22 import Finder
  23 import Module
  24 import Outputable
  25 import Util
  26 import PprType          {- instance Outputable Type; do not delete -}
  27 import Panic            ( GhcException(..) )
  28
  29 import Exception
  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
  45 -----------------------------------------------------------------------------
  46
  47 ghciWelcomeMsg = "\
  48 \ _____  __   __  ____         _________________________________________________\n\
  49 \(|      ||   || (|  |)        GHC Interactive, version 5.00                    \n\
  50 \||  __  ||___|| ||     ()     For Haskell 98.                                  \n\
  51 \||   |) ||---|| ||     ||     http://www.haskell.org/ghc                       \n\
  52 \||   || ||   || ||     (|     Bug reports to: glasgow-haskell-bugs@haskell.org \n\
  53 \(|___|| ||   || (|__|) \\\\______________________________________________________\n"
  54
  55 commands :: [(String, String -> GHCi Bool)]
  56 commands = [
  57   ("add",       keepGoing addModule),
  58   ("cd",        keepGoing changeDirectory),
  59   ("help",      keepGoing help),
  60   ("?",         keepGoing help),
  61   ("load",      keepGoing loadModule),
  62   ("module",    keepGoing setContext),
  63   ("reload",    keepGoing reloadModule),
  64   ("set",       keepGoing setOptions),
  65   ("type",      keepGoing typeOfExpr),
  66   ("unset",     keepGoing unsetOptions),
  67   ("quit",      quit)
  68   ]
  69
  70 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
  71 keepGoing a str = a str >> return False
  72
  73 shortHelpText = "use :? for help.\n"
  74
  75 helpText = "\
  76 \ Commands available from the prompt:\n\
  77 \\
  78 \   <expr>              evaluate <expr>\n\
  79 \   :add <filename>     add a module to the current set\n\
  80 \   :cd <dir>           change directory to <dir>\n\
  81 \   :help, :?           display this list of commands\n\
  82 \   :load <filename>    load a module (and it dependents)\n\
  83 \   :module <mod>       set the context for expression evaluation to <mod>\n\
  84 \   :reload             reload the current module set\n\
  85 \   :set <option> ...   set options\n\
  86 \   :unset <option> ... unset options\n\
  87 \   :type <expr>        show the type of <expr>\n\
  88 \   :quit               exit GHCi\n\
  89 \   :!<command>         run the shell command <command>\n\
  90 \\
  91 \ Options for `:set' and `:unset':\n\
  92 \\
  93 \    +s                 print timing/memory stats after each evaluation\n\
  94 \    +t                 print type after evaluation\n\
  95 \    +r                 revert top-level expressions after each evaluation\n\
  96 \    -<flags>           most GHC command line flags can also be set here\n\
  97 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
  98 \"
  99
 100 interactiveUI :: CmState -> Maybe FilePath -> IO ()
 101 interactiveUI cmstate mod = do
 102    hPutStrLn stdout ghciWelcomeMsg
 103    hFlush stdout
 104    hSetBuffering stdout NoBuffering
 105
 106    -- link in the available packages
 107    pkgs <- getPackageInfo
 108    linkPackages (reverse pkgs)
 109
 110    (cmstate, ok, mods) <-
 111         case mod of
 112              Nothing  -> return (cmstate, True, [])
 113              Just m -> cmLoadModule cmstate m
 114
 115 #ifndef NO_READLINE
 116    Readline.initialize
 117 #endif
 118
 119    prel <- moduleNameToModule defaultCurrentModuleName
 120    writeIORef defaultCurrentModule prel
 121
 122    dflags <- getDynFlags
 123
 124    (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
 125                                 "PrelHandle.hFlush PrelHandle.stdout"
 126    case maybe_stuff of
 127         Nothing -> return ()
 128         Just (hv,_,_) -> writeIORef flush_stdout hv
 129
 130    (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
 131                                 "PrelHandle.hFlush PrelHandle.stdout"
 132    case maybe_stuff of
 133         Nothing -> return ()
 134         Just (hv,_,_) -> writeIORef flush_stderr hv
 135
 136    let this_mod = case mods of
 137                       []   -> prel
 138                       m:ms -> m
 139
 140    (unGHCi runGHCi) GHCiState{ modules = mods,
 141                               current_module = this_mod,
 142                               target = mod,
 143                               cmstate = cmstate,
 144                               options = [ShowTiming],
 145                               last_expr = Nothing}
 146    return ()
 147
 148
 149 runGHCi :: GHCi ()
 150 runGHCi = do
 151   -- read in ./.ghci
 152   dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode))
 153   case dot_ghci of
 154         Left e -> return ()
 155         Right hdl -> fileLoop hdl False
 156
 157   -- read in ~/.ghci
 158   home <- io (IO.try (getEnv "HOME"))
 159   case home of
 160    Left e  -> return ()
 161    Right dir -> 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    when prompt (io (hPutStr hdl (moduleUserString (current_module st) ++ "> ")))
 182    l <- io (IO.try (hGetLine hdl))
 183    case l of
 184         Left e | isEOFError e -> return ()
 185                | otherwise    -> throw e
 186         Right l ->
 187           case remove_spaces l of
 188             "" -> fileLoop hdl prompt
 189             l  -> do quit <- runCommand l
 190                      if quit then return () else fileLoop hdl prompt
 191
 192 #ifndef NO_READLINE
 193 readlineLoop :: GHCi ()
 194 readlineLoop = do
 195    st <- getGHCiState
 196    l <- io (readline (moduleUserString (current_module st) ++ "> "))
 197    case l of
 198         Nothing -> return ()
 199         Just l  ->
 200           case remove_spaces l of
 201             "" -> readlineLoop
 202             l  -> do
 203                   io (addHistory l)
 204                   quit <- runCommand l
 205                   if quit then return () else readlineLoop
 206 #endif
 207
 208 -- Top level exception handler, just prints out the exception
 209 -- and carries on.
 210 runCommand :: String -> GHCi Bool
 211 runCommand c =
 212   ghciHandle (
 213      \other_exception
 214         -> io (do putStrLn ("*** Exception: " ++ show other_exception)
 215                   return False)
 216   ) $
 217   ghciHandleDyn
 218     (\dyn -> case dyn of
 219                 PhaseFailed phase code ->
 220                         io ( putStrLn ("Phase " ++ phase ++ " failed (code "
 221                                         ++ show code ++ ")"))
 222                 Interrupted -> io (putStrLn "Interrupted.")
 223                 _ -> io (putStrLn (show (dyn :: GhcException)))
 224              >> return False
 225     ) $
 226    doCommand c
 227
 228 doCommand (':' : command) = specialCommand command
 229 doCommand ('-':'-':_) = return False    -- comments, useful in scripts
 230 doCommand expr
 231    = do expr_expanded <- expandExpr expr
 232         -- io (putStrLn ( "Before: " ++ expr ++ "\nAfter:  " ++ expr_expanded))
 233         expr_ok <- timeIt (do stuff <- evalExpr expr_expanded
 234                               finishEvalExpr stuff)
 235         when expr_ok (rememberExpr expr_expanded)
 236         return False
 237
 238 -- possibly print the type and revert CAFs after evaluating an expression
 239 finishEvalExpr Nothing = return False
 240 finishEvalExpr (Just (unqual,ty))
 241  = do b <- isOptionSet ShowType
 242       io (when b (printForUser stdout unqual (text "::" <+> ppr ty)))
 243       b <- isOptionSet RevertCAFs
 244       io (when b revertCAFs)
 245       return True
 246
 247 -- Returned Bool indicates whether or not the expr was successfully
 248 -- parsed, renamed and typechecked.
 249 evalExpr :: String -> GHCi (Maybe (PrintUnqualified,Type))
 250 evalExpr expr
 251  | null (filter (not.isSpace) expr)
 252  = return Nothing
 253  | otherwise
 254  = do st <- getGHCiState
 255       dflags <- io (getDynFlags)
 256       (new_cmstate, maybe_stuff) <-
 257          io (cmGetExpr (cmstate st) dflags True (current_module st) expr)
 258       setGHCiState st{cmstate = new_cmstate}
 259       case maybe_stuff of
 260          Nothing -> return Nothing
 261          Just (hv, unqual, ty) -> do io (cmRunExpr hv)
 262                                      flushEverything
 263                                      return (Just (unqual,ty))
 264
 265 flushEverything :: GHCi ()
 266 flushEverything
 267    = io $ do flush_so <- readIORef flush_stdout
 268              cmRunExpr flush_so
 269              flush_se <- readIORef flush_stdout
 270              cmRunExpr flush_se
 271
 272 specialCommand :: String -> GHCi Bool
 273 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 274 specialCommand str = do
 275   let (cmd,rest) = break isSpace str
 276   case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
 277      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 278                                     ++ shortHelpText) >> return False)
 279      [(_,f)] -> f (dropWhile isSpace rest)
 280      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 281                                       " matches multiple commands (" ++
 282                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 283                                          ++ ")") >> return False)
 284
 285 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
 286
 287 -----------------------------------------------------------------------------
 288 -- Commands
 289
 290 help :: String -> GHCi ()
 291 help _ = io (putStr helpText)
 292
 293 addModule :: String -> GHCi ()
 294 addModule _ = throwDyn (OtherError ":add not implemented")
 295
 296 setContext :: String -> GHCi ()
 297 setContext ""
 298   = throwDyn (OtherError "syntax: `:m <module>'")
 299 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
 300   = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
 301 setContext mn
 302   = do m <- io (moduleNameToModule (mkModuleName mn))
 303        st <- getGHCiState
 304        if (isHomeModule m && m `notElem` modules st)
 305           then throwDyn (OtherError (showSDoc (quotes (ppr (moduleName m))
 306                                 <+> text "is not currently loaded, use :load")))
 307           else setGHCiState st{current_module = m}
 308
 309 moduleNameToModule :: ModuleName -> IO Module
 310 moduleNameToModule mn
 311  = do maybe_stuff <- findModule mn
 312       case maybe_stuff of
 313          Nothing -> throwDyn (OtherError ("can't find module `"
 314                                             ++ moduleNameUserString mn ++ "'"))
 315          Just (m,_) -> return m
 316
 317 changeDirectory :: String -> GHCi ()
 318 changeDirectory d = io (setCurrentDirectory d)
 319
 320 loadModule :: String -> GHCi ()
 321 loadModule path = timeIt (loadModule' path)
 322
 323 loadModule' path = do
 324   state <- getGHCiState
 325   cmstate1 <- io (cmUnload (cmstate state))
 326   io (revertCAFs)                       -- always revert CAFs on load.
 327   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
 328
 329   def_mod <- io (readIORef defaultCurrentModule)
 330
 331   let new_state = state{
 332                         cmstate = cmstate2,
 333                         modules = mods,
 334                         current_module = case mods of
 335                                            [] -> def_mod
 336                                            xs -> head xs,
 337                         target = Just path
 338                    }
 339   setGHCiState new_state
 340
 341   let mod_commas
 342         | null mods = text "none."
 343         | otherwise = hsep (
 344             punctuate comma (map (text.moduleUserString) mods)) <> text "."
 345   case ok of
 346     False ->
 347        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 348     True  ->
 349        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 350
 351 reloadModule :: String -> GHCi ()
 352 reloadModule "" = do
 353   state <- getGHCiState
 354   case target state of
 355    Nothing -> io (putStr "no current target\n")
 356    Just path
 357       -> do io (revertCAFs)             -- always revert CAFs on reload.
 358             (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
 359             def_mod <- io (readIORef defaultCurrentModule)
 360             setGHCiState
 361                state{cmstate=new_cmstate,
 362                      modules = mods,
 363                      current_module = case mods of
 364                                          [] -> def_mod
 365                                          xs -> head xs
 366                     }
 367
 368 reloadModule _ = noArgs ":reload"
 369
 370 typeOfExpr :: String -> GHCi ()
 371 typeOfExpr str
 372   = do st <- getGHCiState
 373        dflags <- io (getDynFlags)
 374        (new_cmstate, maybe_ty) <- io (cmGetExpr (cmstate st) dflags False
 375                                          (current_module st) str)
 376        setGHCiState st{cmstate = new_cmstate}
 377        case maybe_ty of
 378          Nothing -> return ()
 379          Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
 380
 381 quit :: String -> GHCi Bool
 382 quit _ = return True
 383
 384 shellEscape :: String -> GHCi Bool
 385 shellEscape str = io (system str >> return False)
 386
 387 ----------------------------------------------------------------------------
 388 -- Code for `:set'
 389
 390 -- set options in the interpreter.  Syntax is exactly the same as the
 391 -- ghc command line, except that certain options aren't available (-C,
 392 -- -E etc.)
 393 --
 394 -- This is pretty fragile: most options won't work as expected.  ToDo:
 395 -- figure out which ones & disallow them.
 396
 397 setOptions :: String -> GHCi ()
 398 setOptions ""
 399   = do st <- getGHCiState
 400        let opts = options st
 401        io $ putStrLn (showSDoc (
 402               text "options currently set: " <>
 403               if null opts
 404                    then text "none."
 405                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 406            ))
 407 setOptions str
 408   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 409        let opts = words str
 410            (minus_opts, rest1) = partition isMinus opts
 411            (plus_opts, rest2)  = partition isPlus rest1
 412
 413        if (not (null rest2))
 414           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 415           else do
 416
 417        mapM setOpt plus_opts
 418
 419        -- now, the GHC flags
 420        io (do -- first, static flags
 421               leftovers <- processArgs static_flags minus_opts []
 422
 423               -- then, dynamic flags
 424               dyn_flags <- readIORef v_InitDynFlags
 425               writeIORef v_DynFlags dyn_flags
 426               leftovers <- processArgs dynamic_flags leftovers []
 427               dyn_flags <- readIORef v_DynFlags
 428               writeIORef v_InitDynFlags dyn_flags
 429
 430               if (not (null leftovers))
 431                  then throwDyn (OtherError ("unrecognised flags: " ++
 432                                                 unwords leftovers))
 433                  else return ()
 434          )
 435
 436 unsetOptions :: String -> GHCi ()
 437 unsetOptions str
 438   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 439        let opts = words str
 440            (minus_opts, rest1) = partition isMinus opts
 441            (plus_opts, rest2)  = partition isPlus rest1
 442
 443        if (not (null rest2))
 444           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 445           else do
 446
 447        mapM unsetOpt plus_opts
 448
 449        -- can't do GHC flags for now
 450        if (not (null minus_opts))
 451           then throwDyn (OtherError "can't unset GHC command-line flags")
 452           else return ()
 453
 454 isMinus ('-':s) = True
 455 isMinus _ = False
 456
 457 isPlus ('+':s) = True
 458 isPlus _ = False
 459
 460 setOpt ('+':str)
 461   = case strToGHCiOpt str of
 462         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 463         Just o  -> setOption o
 464
 465 unsetOpt ('+':str)
 466   = case strToGHCiOpt str of
 467         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 468         Just o  -> unsetOption o
 469
 470 strToGHCiOpt :: String -> (Maybe GHCiOption)
 471 strToGHCiOpt "s" = Just ShowTiming
 472 strToGHCiOpt "t" = Just ShowType
 473 strToGHCiOpt "r" = Just RevertCAFs
 474 strToGHCiOpt _   = Nothing
 475
 476 optToStr :: GHCiOption -> String
 477 optToStr ShowTiming = "s"
 478 optToStr ShowType   = "t"
 479 optToStr RevertCAFs = "r"
 480
 481 -----------------------------------------------------------------------------
 482 -- Code to do last-expression-entered stuff.  (a.k.a the $$ facility)
 483
 484 -- Take a string and replace $$s in it with the last expr, if any.
 485 expandExpr :: String -> GHCi String
 486 expandExpr str
 487    = do mle <- getLastExpr
 488         return (outside mle str)
 489      where
 490         outside mle ('$':'$':cs)
 491            = case mle of
 492                 Just le -> " (" ++ le ++ ") " ++ outside mle cs
 493                 Nothing -> outside mle cs
 494
 495         outside mle []           = []
 496         outside mle ('"':str)    = '"' : inside2 mle str   -- "
 497         outside mle ('\'':str)   = '\'' : inside1 mle str   -- '
 498         outside mle (c:cs)       = c : outside mle cs
 499
 500         inside2 mle ('"':cs)  = '"' : outside mle cs   -- "
 501         inside2 mle (c:cs)    = c : inside2 mle cs
 502         inside2 mle []        = []
 503
 504         inside1 mle ('\'':cs) = '\'': outside mle cs
 505         inside1 mle (c:cs)    = c : inside1 mle cs
 506         inside1 mle []        = []
 507
 508
 509 rememberExpr :: String -> GHCi ()
 510 rememberExpr str
 511    = do let cleaned = (clean . reverse . clean . reverse) str
 512         let forget_me_not | null cleaned = Nothing
 513                           | otherwise    = Just cleaned
 514         setLastExpr forget_me_not
 515      where
 516         clean = dropWhile isSpace
 517
 518
 519 -----------------------------------------------------------------------------
 520 -- GHCi monad
 521
 522 data GHCiState = GHCiState
 523      {
 524         modules        :: [Module],
 525         current_module :: Module,
 526         target         :: Maybe FilePath,
 527         cmstate        :: CmState,
 528         options        :: [GHCiOption],
 529         last_expr      :: Maybe String
 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 defaultCurrentModuleName = mkModuleName "Prelude"
 539 GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module)
 540
 541 GLOBAL_VAR(flush_stdout, error "no flush_stdout", HValue)
 542 GLOBAL_VAR(flush_stderr, error "no flush_stdout", HValue)
 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 getLastExpr :: GHCi (Maybe String)
 569 getLastExpr
 570  = do st <- getGHCiState ; return (last_expr st)
 571
 572 setLastExpr :: Maybe String -> GHCi ()
 573 setLastExpr last_expr
 574  = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr})
 575
 576 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 577
 578 -- recursive exception handlers
 579 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 580 ghciHandle h (GHCi m) = GHCi $ \s ->
 581    Exception.catch (m s) (\e -> unGHCi (ghciHandle h (h e)) s)
 582
 583 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 584    Exception.catchDyn (m s) (\e -> unGHCi (ghciHandleDyn h (h e)) s)
 585
 586 -----------------------------------------------------------------------------
 587 -- package loader
 588
 589 linkPackages :: [Package] -> IO ()
 590 linkPackages pkgs = mapM_ linkPackage pkgs
 591
 592 linkPackage :: Package -> IO ()
 593 -- ignore rts and gmp for now (ToDo; better?)
 594 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
 595 linkPackage pkg = do
 596   putStr ("Loading package " ++ name pkg ++ " ... ")
 597   let dirs = library_dirs pkg
 598   let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
 599   mapM (linkOneObj dirs) objs
 600   putStr "resolving ... "
 601   resolveObjs
 602   putStrLn "done."
 603
 604 linkOneObj dirs obj = do
 605   filename <- findFile dirs obj
 606   loadObj filename
 607
 608 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
 609 findFile (d:ds) obj = do
 610   let path = d ++ '/':obj
 611   b <- doesFileExist path
 612   if b then return path else findFile ds obj
 613
 614 -----------------------------------------------------------------------------
 615 -- timing & statistics
 616
 617 timeIt :: GHCi a -> GHCi a
 618 timeIt action
 619   = do b <- isOptionSet ShowTiming
 620        if not b
 621           then action
 622           else do allocs1 <- io $ getAllocations
 623                   time1   <- io $ getCPUTime
 624                   a <- action
 625                   allocs2 <- io $ getAllocations
 626                   time2   <- io $ getCPUTime
 627                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 628                   return a
 629
 630 foreign import "getAllocations" getAllocations :: IO Int
 631
 632 printTimes :: Int -> Integer -> IO ()
 633 printTimes allocs psecs
 634    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 635             secs_str = showFFloat (Just 2) secs
 636         putStrLn (showSDoc (
 637                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 638                          int allocs <+> text "bytes")))
 639
 640 -----------------------------------------------------------------------------
 641 -- reverting CAFs
 642
 643 foreign import revertCAFs :: IO ()      -- make it "safe", just in case