lhc-0.10: src/LhcMain.hs
module LhcMain (tryMain) where
import System.Directory
import System.FilePath
import System.Environment
import qualified Data.Version as Version
import Paths_lhc
import qualified Data.ByteString.Lazy.Char8 as L
import System.IO
import System.Exit
import qualified Data.Map as Map
import Data.Binary
import Data.Maybe
import Control.Monad
import Data.Time; import Text.Printf
import CompactString
import qualified Language.Core as Core
import Grin.SimpleCore
import Grin.FromCore
import Grin.Pretty
import qualified Grin.SimpleCore.DeadCode as Simple
import qualified Grin.Optimize.Simple as Simple
import qualified Grin.Optimize.Case as Case
import qualified Grin.DeadCode as DeadCode
import qualified Grin.PreciseDeadCode as DeadCode
import qualified Grin.Optimize.Inline as Inline
--import Grin.Rename
import qualified Grin.HPT as HPT
import qualified Grin.Lowering.Apply as Apply
import qualified Grin.Stage2.FromStage1 as Stage2
import qualified Grin.Stage2.Pretty as Stage2
import qualified Grin.Stage2.Optimize.Simple as Stage2.Simple
import qualified Grin.Stage2.Optimize.Case as Stage2.Case
import qualified Grin.Stage2.Backend.LLVM as Backend.LLVM
import qualified Grin.Stage2.Backend.C as Backend.C
import qualified Grin.Stage2.DeadCode as Stage2
import qualified Grin.Stage2.Rename as Stage2
import Manager
--import Tick
-- TODO: We need proper command line parsing.
tryMain :: IO ()
tryMain = do args <- getArgs
case args of
("install":files) -> mapM_ installCoreFile files >> exitWith ExitSuccess
("compile":files) -> build Compile files >> exitWith ExitSuccess
("benchmark":files) -> build Benchmark files >> exitWith ExitSuccess
("llvm":files) -> build LLVM files
["--numeric-version"] -> putStrLn (Version.showVersion version) >> exitWith ExitSuccess
_ -> return ()
installCoreFile :: FilePath -> IO ()
installCoreFile path
= do inp <- L.readFile path
hPutStr stderr $ "Parsing " ++ path ++ "..."
hFlush stdout
case Core.parseModule "file" inp of
Left errs -> hPutStrLn stderr "errors: " >> print errs
Right mod -> do hPutStrLn stderr " done"
dataDir <- getAppUserDataDirectory "lhc"
let packagesDir = dataDir </> "packages"
let smod = coreToSimpleCore mod
createDirectoryIfMissing False (packagesDir </> modulePackage smod)
encodeFile (packagesDir </> modulePackage smod </> moduleName smod) smod
data Action = Compile | Benchmark | LLVM
build :: Action -> [FilePath] -> IO ()
build action files@(file:_)
= do mods <- mapM parseCore files
libs <- loadAllLibraries
let primModule = SimpleModule { modulePackage = "ghczmprim"
, moduleName = "GHCziPrim"
, moduleTypes = [SimpleType (fromString "ghc-prim:GHC.Prim.(# #)") 1
,SimpleType (fromString "ghc-prim:GHC.Prim.(#,#)") 2
,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,#)") 3
,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,#)") 4
,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,#)") 5
,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,#)") 6
,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,,#)") 7
,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,,,#)") 8
,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,,,,#)") 9
,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,,,,,#)") 10
,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,,,,,,#)") 11
,SimpleType (fromString "ghc-prim:GHC.Prim.(#,,,,,,,,,,,#)") 12
]
, moduleEnums = []
, moduleDefs = [] }
let allModules = Map.insert (modulePackage primModule, moduleName primModule) primModule $
foldr (\mod -> Map.insert (modulePackage mod, moduleName mod) mod) libs mods
-- libs
(tdefs, enums, defs) = Simple.removeDeadCode [("main","Main")] ["main::Main.main"] allModules
grin = coreToGrin tdefs enums defs
let target = replaceExtension file "lhc"
first_fixpoint <- transformer (replaceExtension file "grin")
[ Step "Optimize" Simple.optimize
, Step "Remove dead code" DeadCode.trimDeadCode
, Step "Inline" Inline.inlinePass ]
grin
let applyLowered = Apply.lower first_fixpoint
hptEnv = HPT.mkEnvironment applyLowered
(iterations, hpt) = HPT.analyze applyLowered
(evalLowered, hpt') = HPT.lower hpt applyLowered
timeIt "Lowering apply primitives" $ outputGrin target "_apply" applyLowered
timeIt "Heap points-to analysis" $ do forM_ iterations $ \_ -> do putStr "."; hFlush stdout
outputGrin target "_eval" evalLowered
putStrLn $ "HPT fixpoint found in " ++ show (length iterations) ++ " iterations."
let stage2_raw = Stage2.convert hpt' evalLowered
second_fixpoint <- transformer (replaceExtension file "grin2")
[ Step "Optimize" Stage2.Simple.optimize
, Step "Remove dead code" Stage2.trimDeadCode
, Step "Case optimize" Stage2.Case.optimize
, Step "Rename" Stage2.rename
, Step "Apply rewrite rules" Stage2.Case.applyRewriteRules
, Step "Inline" (Stage2.trimDeadCode . Stage2.Case.inlinePass)
, Step "Apply rewrite rules" Stage2.Case.applyRewriteRules
, Step "Optimize" (Stage2.Simple.optimize . Stage2.trimDeadCode)
]
stage2_raw
let stage2_out = second_fixpoint
outputGrin2 target "" stage2_out
case action of
Benchmark -> timeIt "Compiling C code" $ Backend.C.compileFastCode stage2_out (dropExtension target)
LLVM -> timeIt "Compiling LLVM code" $ Backend.LLVM.compile stage2_out target
Compile -> timeIt "Compiling C code" $ Backend.C.compile stage2_out (dropExtension target)
outputGrin file variant grin
= do let outputFile = replaceExtension file ("grin"++variant)
writeFile outputFile (show $ ppGrin grin)
return ()
outputGrin2 file variant grin
= do let outputFile = replaceExtension file ("grin2"++variant)
writeFile outputFile (show $ Stage2.ppGrin grin)
return ()
loadAllLibraries :: IO (Map.Map ModuleIdent SimpleModule)
loadAllLibraries
= do dataDir <- getAppUserDataDirectory "lhc"
let packageDir = dataDir </> "packages"
packages <- getDirectoryContents packageDir
smods <- forM (filter (`notElem` [".",".."]) packages) $ \package ->
do modules <- getDirectoryContents (packageDir </> package)
forM (filter (`notElem` [".",".."]) modules) $ \mod ->
do -- putStrLn $ "Loading: " ++ (packageDir </> package </> mod)
smod <- decodeFile (packageDir </> package </> mod)
return ((package,mod),smod)
return $ Map.fromList [ (ident, mod) | (ident,mod) <- concat smods ]
parseCore :: FilePath -> IO SimpleModule
parseCore path
= do inp <- L.readFile path
case Core.parseModule path inp of
Left errs -> error (show errs)
Right mod -> do --putStrLn $ "parsing done: " ++ path
return (coreToSimpleCore mod)
{-
timeIt :: String -> IO a -> IO a
timeIt msg action
= do printf "%-40s" (msg ++ ": ")
hFlush stdout
s <- getCurrentTime
a <- action
e <- getCurrentTime
printf "%.2fs\n" (realToFrac (diffUTCTime e s) :: Double)
return a
-}