Skip to content

Instantly share code, notes, and snippets.

@acowley
Created December 22, 2015 18:17
Show Gist options
  • Save acowley/ea78b1dd5ead59621d69 to your computer and use it in GitHub Desktop.
Save acowley/ea78b1dd5ead59621d69 to your computer and use it in GitHub Desktop.
Use the GHC API to time the type checker
import Control.Arrow ((***))
import Control.Monad (replicateM_)
import Control.Monad.IO.Class
import Data.List (isPrefixOf)
import Data.Time.Clock
import DynFlags (defaultFatalMessager, defaultFlushOut, PkgConfRef(PkgConfFile))
import GHC
import GHC.Paths (libdir)
import System.FilePath (takeBaseName, splitExtension, addExtension)
import Text.Printf
data Timing = Timing { parseTime :: Double
, typecheckTime :: Double
, desugarTime :: Double }
deriving Show
showTCTime :: Timing -> String
showTCTime = printf "%0.2f ms" . (*1000) . typecheckTime
main :: IO ()
main = do runTest "benchmarks/CompilerVinyl.hs" >>=
print . (showTCTime***showTCTime)
runTest "benchmarks/CompilerTree.hs" >>=
print . (showTCTime *** showTCTime)
runTest "benchmarks/CompilerTree2.hs" >>=
print . (showTCTime *** showTCTime)
timeThis :: MonadIO m => m a -> m (a, Double)
timeThis m = do start <- liftIO getCurrentTime
res <- m
replicateM_ 9 m
stop <- res `seq` liftIO getCurrentTime
return $ (res, realToFrac (diffUTCTime stop start) * 0.1)
-- | Find the sandbox package db
findDB :: IO String
findDB = do
lns <- readFile "cabal.sandbox.config"
case filter (isPrefixOf "package-db:") (lines lns) of
[dbline] -> return $ drop (length "package-db: ") dbline
_ -> error "Error parsing cabal.sandbox.config"
-- | Times parsing, type checking, and desugaring for the given file.
runTypechecker :: FilePath -> Ghc Timing
runTypechecker targetFile = do
target <- guessTarget targetFile Nothing
setTargets [target]
load LoadAllTargets
modSum <- getModSummary $ mkModuleName (takeBaseName targetFile)
(p,ptime) <- timeThis $ parseModule modSum
(t,tctime) <- timeThis $ typecheckModule p
(_d, dtime) <- timeThis $ desugarModule t
-- l <- loadModule d
-- n <- getNamesInScope
-- c <- return (coreModule d)
-- g <- getModuleGraph
return $ Timing ptime tctime dtime
-- | Sets up a GHC session, type checks one module, then another one
-- /in the same session/. The second one's name is inferred from the
-- argument. If \"Foo.hs\" is the argument, then \"Foo.hs\" is loaded
-- (and timed) first, followed by \"FooUse.hs\" in the same
-- session. This lets you separate setup code from use code.
runTest :: FilePath -> IO (Timing, Timing)
runTest targetFile =
defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
dbPath <- liftIO findDB
let dflags' = dflags { extraPkgConfs = (++) [PkgConfFile dbPath] }
setSessionDynFlags dflags'
t1 <- runTypechecker targetFile
let useFile = let (f,e) = splitExtension targetFile
in addExtension (f ++ "Use") e
t2 <- runTypechecker useFile
return (t1,t2)
{-
I have this stanza in the .cabal file for my test project
benchmark compile
type: exitcode-stdio-1.0
hs-source-dirs: benchmarks
main-is: Compiler.hs
build-depends: base >= 4.8 && < 5, time, ghc, filepath, ghc-paths,
transformers
default-language: Haskell2010
Note that all dependencies should be installed in the sandbox. Also,
if there is a library in the test project, it must be *installed* in
the sandbox for GHC to find it.
-}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment