ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.34 2001/02/07 10:45:43 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 (putStrLn (show other_exception)) >> return False
 215   ) $
 216   ghciHandleDyn
 217     (\dyn -> case dyn of
 218                 PhaseFailed phase code ->
 219                         io ( putStrLn ("Phase " ++ phase ++ " failed (code "
 220                                         ++ show code ++ ")"))
 221                 Interrupted -> io (putStrLn "Interrupted.")
 222                 _ -> io (putStrLn (show (dyn :: GhcException)))
 223              >> return False
 224     ) $
 225    doCommand c
 226
 227 doCommand (':' : command) = specialCommand command
 228 doCommand ('-':'-':_) = return False    -- comments, useful in scripts
 229 doCommand expr
 230    = do expr_expanded <- expandExpr expr
 231         -- io (putStrLn ( "Before: " ++ expr ++ "\nAfter:  " ++ expr_expanded))
 232         expr_ok <- timeIt (do stuff <- evalExpr expr_expanded
 233                               finishEvalExpr stuff)
 234         when expr_ok (rememberExpr expr_expanded)
 235         return False
 236
 237 -- possibly print the type and revert CAFs after evaluating an expression
 238 finishEvalExpr Nothing = return False
 239 finishEvalExpr (Just (unqual,ty))
 240  = do b <- isOptionSet ShowType
 241       io (when b (printForUser stdout unqual (text "::" <+> ppr ty)))
 242       b <- isOptionSet RevertCAFs
 243       io (when b revertCAFs)
 244       return True
 245
 246 -- Returned Bool indicates whether or not the expr was successfully
 247 -- parsed, renamed and typechecked.
 248 evalExpr :: String -> GHCi (Maybe (PrintUnqualified,Type))
 249 evalExpr expr
 250  | null (filter (not.isSpace) expr)
 251  = return Nothing
 252  | otherwise
 253  = do st <- getGHCiState
 254       dflags <- io (getDynFlags)
 255       (new_cmstate, maybe_stuff) <-
 256          io (cmGetExpr (cmstate st) dflags True (current_module st) expr)
 257       setGHCiState st{cmstate = new_cmstate}
 258       case maybe_stuff of
 259          Nothing -> return Nothing
 260          Just (hv, unqual, ty) -> do io (cmRunExpr hv)
 261                                      flushEverything
 262                                      return (Just (unqual,ty))
 263
 264 flushEverything :: GHCi ()
 265 flushEverything
 266    = io $ do flush_so <- readIORef flush_stdout
 267              cmRunExpr flush_so
 268              flush_se <- readIORef flush_stdout
 269              cmRunExpr flush_se
 270
 271 specialCommand :: String -> GHCi Bool
 272 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 273 specialCommand str = do
 274   let (cmd,rest) = break isSpace str
 275   case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
 276      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 277                                     ++ shortHelpText) >> return False)
 278      [(_,f)] -> f (dropWhile isSpace rest)
 279      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 280                                       " matches multiple commands (" ++
 281                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 282                                          ++ ")") >> return False)
 283
 284 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
 285
 286 -----------------------------------------------------------------------------
 287 -- Commands
 288
 289 help :: String -> GHCi ()
 290 help _ = io (putStr helpText)
 291
 292 addModule :: String -> GHCi ()
 293 addModule _ = throwDyn (OtherError ":add not implemented")
 294
 295 setContext :: String -> GHCi ()
 296 setContext ""
 297   = throwDyn (OtherError "syntax: `:m <module>'")
 298 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
 299   = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
 300 setContext mn
 301   = do m <- io (moduleNameToModule (mkModuleName mn))
 302        st <- getGHCiState
 303        if (isHomeModule m && m `notElem` modules st)
 304           then throwDyn (OtherError (showSDoc (quotes (ppr (moduleName m))
 305                                 <+> text "is not currently loaded, use :load")))
 306           else setGHCiState st{current_module = m}
 307
 308 moduleNameToModule :: ModuleName -> IO Module
 309 moduleNameToModule mn
 310  = do maybe_stuff <- findModule mn
 311       case maybe_stuff of
 312          Nothing -> throwDyn (OtherError ("can't find module `"
 313                                             ++ moduleNameUserString mn ++ "'"))
 314          Just (m,_) -> return m
 315
 316 changeDirectory :: String -> GHCi ()
 317 changeDirectory d = io (setCurrentDirectory d)
 318
 319 loadModule :: String -> GHCi ()
 320 loadModule path = timeIt (loadModule' path)
 321
 322 loadModule' path = do
 323   state <- getGHCiState
 324   cmstate1 <- io (cmUnload (cmstate state))
 325   io (revertCAFs)                       -- always revert CAFs on load.
 326   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
 327
 328   def_mod <- io (readIORef defaultCurrentModule)
 329
 330   let new_state = state{
 331                         cmstate = cmstate2,
 332                         modules = mods,
 333                         current_module = case mods of
 334                                            [] -> def_mod
 335                                            xs -> head xs,
 336                         target = Just path
 337                    }
 338   setGHCiState new_state
 339
 340   let mod_commas
 341         | null mods = text "none."
 342         | otherwise = hsep (
 343             punctuate comma (map (text.moduleUserString) mods)) <> text "."
 344   case ok of
 345     False ->
 346        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 347     True  ->
 348        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 349
 350 reloadModule :: String -> GHCi ()
 351 reloadModule "" = do
 352   state <- getGHCiState
 353   case target state of
 354    Nothing -> io (putStr "no current target\n")
 355    Just path
 356       -> do io (revertCAFs)             -- always revert CAFs on reload.
 357             (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
 358             def_mod <- io (readIORef defaultCurrentModule)
 359             setGHCiState
 360                state{cmstate=new_cmstate,
 361                      modules = mods,
 362                      current_module = case mods of
 363                                          [] -> def_mod
 364                                          xs -> head xs
 365                     }
 366
 367 reloadModule _ = noArgs ":reload"
 368
 369 typeOfExpr :: String -> GHCi ()
 370 typeOfExpr str
 371   = do st <- getGHCiState
 372        dflags <- io (getDynFlags)
 373        (new_cmstate, maybe_ty) <- io (cmGetExpr (cmstate st) dflags False
 374                                          (current_module st) str)
 375        setGHCiState st{cmstate = new_cmstate}
 376        case maybe_ty of
 377          Nothing -> return ()
 378          Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
 379
 380 quit :: String -> GHCi Bool
 381 quit _ = return True
 382
 383 shellEscape :: String -> GHCi Bool
 384 shellEscape str = io (system str >> return False)
 385
 386 ----------------------------------------------------------------------------
 387 -- Code for `:set'
 388
 389 -- set options in the interpreter.  Syntax is exactly the same as the
 390 -- ghc command line, except that certain options aren't available (-C,
 391 -- -E etc.)
 392 --
 393 -- This is pretty fragile: most options won't work as expected.  ToDo:
 394 -- figure out which ones & disallow them.
 395
 396 setOptions :: String -> GHCi ()
 397 setOptions ""
 398   = do st <- getGHCiState
 399        let opts = options st
 400        io $ putStrLn (showSDoc (
 401               text "options currently set: " <>
 402               if null opts
 403                    then text "none."
 404                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 405            ))
 406 setOptions str
 407   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 408        let opts = words str
 409            (minus_opts, rest1) = partition isMinus opts
 410            (plus_opts, rest2)  = partition isPlus rest1
 411
 412        if (not (null rest2))
 413           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 414           else do
 415
 416        mapM setOpt plus_opts
 417
 418        -- now, the GHC flags
 419        io (do -- first, static flags
 420               leftovers <- processArgs static_flags minus_opts []
 421
 422               -- then, dynamic flags
 423               dyn_flags <- readIORef v_InitDynFlags
 424               writeIORef v_DynFlags dyn_flags
 425               leftovers <- processArgs dynamic_flags leftovers []
 426               dyn_flags <- readIORef v_DynFlags
 427               writeIORef v_InitDynFlags dyn_flags
 428
 429               if (not (null leftovers))
 430                  then throwDyn (OtherError ("unrecognised flags: " ++
 431                                                 unwords leftovers))
 432                  else return ()
 433          )
 434
 435 unsetOptions :: String -> GHCi ()
 436 unsetOptions str
 437   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 438        let opts = words str
 439            (minus_opts, rest1) = partition isMinus opts
 440            (plus_opts, rest2)  = partition isPlus rest1
 441
 442        if (not (null rest2))
 443           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 444           else do
 445
 446        mapM unsetOpt plus_opts
 447
 448        -- can't do GHC flags for now
 449        if (not (null minus_opts))
 450           then throwDyn (OtherError "can't unset GHC command-line flags")
 451           else return ()
 452
 453 isMinus ('-':s) = True
 454 isMinus _ = False
 455
 456 isPlus ('+':s) = True
 457 isPlus _ = False
 458
 459 setOpt ('+':str)
 460   = case strToGHCiOpt str of
 461         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 462         Just o  -> setOption o
 463
 464 unsetOpt ('+':str)
 465   = case strToGHCiOpt str of
 466         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 467         Just o  -> unsetOption o
 468
 469 strToGHCiOpt :: String -> (Maybe GHCiOption)
 470 strToGHCiOpt "s" = Just ShowTiming
 471 strToGHCiOpt "t" = Just ShowType
 472 strToGHCiOpt "r" = Just RevertCAFs
 473 strToGHCiOpt _   = Nothing
 474
 475 optToStr :: GHCiOption -> String
 476 optToStr ShowTiming = "s"
 477 optToStr ShowType   = "t"
 478 optToStr RevertCAFs = "r"
 479
 480 -----------------------------------------------------------------------------
 481 -- Code to do last-expression-entered stuff.  (a.k.a the $$ facility)
 482
 483 -- Take a string and replace $$s in it with the last expr, if any.
 484 expandExpr :: String -> GHCi String
 485 expandExpr str
 486    = do mle <- getLastExpr
 487         return (outside mle str)
 488      where
 489         outside mle ('$':'$':cs)
 490            = case mle of
 491                 Just le -> " (" ++ le ++ ") " ++ outside mle cs
 492                 Nothing -> outside mle cs
 493
 494         outside mle []           = []
 495         outside mle ('"':str)    = '"' : inside2 mle str   -- "
 496         outside mle ('\'':str)   = '\'' : inside1 mle str   -- '
 497         outside mle (c:cs)       = c : outside mle cs
 498
 499         inside2 mle ('"':cs)  = '"' : outside mle cs   -- "
 500         inside2 mle (c:cs)    = c : inside2 mle cs
 501         inside2 mle []        = []
 502
 503         inside1 mle ('\'':cs) = '\'': outside mle cs
 504         inside1 mle (c:cs)    = c : inside1 mle cs
 505         inside1 mle []        = []
 506
 507
 508 rememberExpr :: String -> GHCi ()
 509 rememberExpr str
 510    = do let cleaned = (clean . reverse . clean . reverse) str
 511         let forget_me_not | null cleaned = Nothing
 512                           | otherwise    = Just cleaned
 513         setLastExpr forget_me_not
 514      where
 515         clean = dropWhile isSpace
 516
 517
 518 -----------------------------------------------------------------------------
 519 -- GHCi monad
 520
 521 data GHCiState = GHCiState
 522      {
 523         modules        :: [Module],
 524         current_module :: Module,
 525         target         :: Maybe FilePath,
 526         cmstate        :: CmState,
 527         options        :: [GHCiOption],
 528         last_expr      :: Maybe String
 529      }
 530
 531 data GHCiOption
 532         = ShowTiming            -- show time/allocs after evaluation
 533         | ShowType              -- show the type of expressions
 534         | RevertCAFs            -- revert CAFs after every evaluation
 535         deriving Eq
 536
 537 defaultCurrentModuleName = mkModuleName "Prelude"
 538 GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module)
 539
 540 GLOBAL_VAR(flush_stdout, error "no flush_stdout", HValue)
 541 GLOBAL_VAR(flush_stderr, error "no flush_stdout", HValue)
 542
 543 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 544
 545 instance Monad GHCi where
 546   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 547   return a  = GHCi $ \s -> return (s,a)
 548
 549 getGHCiState   = GHCi $ \s -> return (s,s)
 550 setGHCiState s = GHCi $ \_ -> return (s,())
 551
 552 isOptionSet :: GHCiOption -> GHCi Bool
 553 isOptionSet opt
 554  = do st <- getGHCiState
 555       return (opt `elem` options st)
 556
 557 setOption :: GHCiOption -> GHCi ()
 558 setOption opt
 559  = do st <- getGHCiState
 560       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 561
 562 unsetOption :: GHCiOption -> GHCi ()
 563 unsetOption opt
 564  = do st <- getGHCiState
 565       setGHCiState (st{ options = filter (/= opt) (options st) })
 566
 567 getLastExpr :: GHCi (Maybe String)
 568 getLastExpr
 569  = do st <- getGHCiState ; return (last_expr st)
 570
 571 setLastExpr :: Maybe String -> GHCi ()
 572 setLastExpr last_expr
 573  = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr})
 574
 575 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 576
 577 ghciHandle h (GHCi m) = GHCi $ \s ->
 578    Exception.catch (m s) (\e -> unGHCi (h e) s)
 579 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 580    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 581
 582 -----------------------------------------------------------------------------
 583 -- package loader
 584
 585 linkPackages :: [Package] -> IO ()
 586 linkPackages pkgs = mapM_ linkPackage pkgs
 587
 588 linkPackage :: Package -> IO ()
 589 -- ignore rts and gmp for now (ToDo; better?)
 590 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
 591 linkPackage pkg = do
 592   putStr ("Loading package " ++ name pkg ++ " ... ")
 593   let dirs = library_dirs pkg
 594   let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
 595   mapM (linkOneObj dirs) objs
 596   putStr "resolving ... "
 597   resolveObjs
 598   putStrLn "done."
 599
 600 linkOneObj dirs obj = do
 601   filename <- findFile dirs obj
 602   loadObj filename
 603
 604 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
 605 findFile (d:ds) obj = do
 606   let path = d ++ '/':obj
 607   b <- doesFileExist path
 608   if b then return path else findFile ds obj
 609
 610 -----------------------------------------------------------------------------
 611 -- timing & statistics
 612
 613 timeIt :: GHCi a -> GHCi a
 614 timeIt action
 615   = do b <- isOptionSet ShowTiming
 616        if not b
 617           then action
 618           else do allocs1 <- io $ getAllocations
 619                   time1   <- io $ getCPUTime
 620                   a <- action
 621                   allocs2 <- io $ getAllocations
 622                   time2   <- io $ getCPUTime
 623                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 624                   return a
 625
 626 foreign import "getAllocations" getAllocations :: IO Int
 627
 628 printTimes :: Int -> Integer -> IO ()
 629 printTimes allocs psecs
 630    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 631             secs_str = showFFloat (Just 2) secs
 632         putStrLn (showSDoc (
 633                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 634                          int allocs <+> text "bytes")))
 635
 636 -----------------------------------------------------------------------------
 637 -- reverting CAFs
 638
 639 foreign import revertCAFs :: IO ()      -- make it "safe", just in case