ghc-core 0.5.5 → 0.5.6
raw patch · 2 files changed
+71/−180 lines, 2 files
Files
- ghc-core.cabal +3/−6
- ghc-core.hs +68/−174
ghc-core.cabal view
@@ -1,5 +1,5 @@ name: ghc-core-version: 0.5.5+version: 0.5.6 license: BSD3 license-file: LICENSE author: Don Stewart@@ -12,7 +12,7 @@ readable, colourised manner, in a pager. Unix systems only, currently. .- Usage: + Usage: . > ghc-core A.hs .@@ -21,8 +21,6 @@ build-type: Simple cabal-version: >= 1.2 --- Technically, hscolour-1.10.* will work too if we replace the--- 'NoLit' constructor with 'False' in the call to 'hscolour'. executable ghc-core build-depends: base >= 4 && < 5, process >=1.0.1,@@ -31,5 +29,4 @@ directory, filepath main-is: ghc-core.hs- ghc-options: -Wall- extensions: PatternGuards+ ghc-options: -Wall -O2
ghc-core.hs view
@@ -17,35 +17,27 @@ -- -- > ghc-core zipwith ----- > ghc-core -fvia-C zipwith +-- > ghc-core -fvia-C zipwith -- ------------------------------------------------------------------------ -import Control.Concurrent+import Control.Applicative import Control.Exception as E-import Control.Monad+import Data.Maybe import System.Console.GetOpt import System.Directory import System.Environment import System.Exit import System.FilePath import System.IO-import System.Process hiding (readProcess)-import Text.Printf+import System.Process import Text.Regex.PCRE.Light.Char8 -- BSD-licensed Haskell syntax highlighting, based on Programmatica import Language.Haskell.Colorize -{--import Language.Haskell.HsColour-import Language.Haskell.HsColour.Colourise--- 'Literate' is hscolour-1.11 only. 'Bool' was used in hscolour-1.10-import Language.Haskell.HsColour.Options (Literate(..))--}- ------------------------------------------------------------------------ -- -- Command line parsing@@ -53,7 +45,6 @@ data Options = Options { optHelp :: Bool--- , optFormat :: Output , optGhcExe :: String , optAsm :: Bool , optSyntax :: Bool@@ -63,47 +54,33 @@ defaultOptions :: Options defaultOptions = Options { optHelp = False--- , optFormat = TTY , optGhcExe = "ghc" , optAsm = True , optSyntax = True , optCast = True } --- formats :: [(String, Output)]--- formats = [("css", CSS), ("html", HTML), ("tty", TTY)]- options :: [OptDescr (Options -> Options)] options =- [ -- Option ['f'] ["format"]- -- (ReqArg (\x opts -> opts { optFormat = fromString x }) "FORMAT")- -- ("Output format " ++ formats' ++ ".")- Option ['h'] ["help"]- (NoArg (\opts -> opts { optHelp = True }))- "Print this help message."- ,Option [] ["with-ghc"]- (ReqArg (\x opts -> opts { optGhcExe = x }) "PROGRAM")- "Ghc executable to use."- ,Option [] ["no-asm"]- (NoArg (\opts -> opts { optAsm = False }))- "Don't output generated assembly code."- ,Option [] ["no-syntax"]- (NoArg (\opts -> opts { optSyntax = False }))- "Don't colorize generated code."- ,Option [] ["no-cast"]- (NoArg (\opts -> opts { optCast = False }))- "Don't output calls to cast in generated code."+ [ Option ['h'] ["help"]+ (NoArg (\opts -> opts { optHelp = True }))+ "Print this help message."+ , Option ['w'] ["with-ghc"]+ (ReqArg (\x opts -> opts { optGhcExe = x }) "PROGRAM")+ "Ghc executable to use."+ , Option [] ["no-asm"]+ (NoArg (\opts -> opts { optAsm = False }))+ "Don't output generated assembly code."+ , Option [] ["no-syntax"]+ (NoArg (\opts -> opts { optSyntax = False }))+ "Don't colorize generated code."+ , Option [] ["no-cast"]+ (NoArg (\opts -> opts { optCast = False }))+ "Don't output calls to cast in generated code." ]- where-{- fromString f = fromMaybe (formatError f) (lookup f formats)- formatError f = error $- "invalid format `" ++ f ++ "'"- ++ ", must be one of " ++ formats' ++ "."- formats' = "(" ++ concat (intersperse ", " (map fst formats)) ++ ")"--} parseOptions :: [String] -> IO (Options, [String])-parseOptions argv = +parseOptions argv = case getOpt RequireOrder options argv of (o, n, []) -> let o' = foldl (flip ($)) defaultOptions o in if optHelp o'@@ -111,7 +88,8 @@ exitWith ExitSuccess else return (o', n) (_, _, es) -> ioError (userError (concat es ++ usageInfo header options))- where header = "Usage: ghc-core [OPTION...] [--] [GHC_OPTION...] [files...]"+ where+ header = "Usage: ghc-core [OPTION...] [--] [GHC_OPTION...] [files...]" isExtCoreFile :: FilePath -> Bool isExtCoreFile = (== ".hcr") . takeExtension@@ -122,78 +100,42 @@ -- Parse command line (opts, args) <- getArgs >>= parseOptions - -- Read colors from .hscolour--- colourPrefs <- readColourPrefs-- mv <- getEnvMaybe "PAGER"- let less = case mv of Just s -> case s of "less" -> "less -f" ; _ -> s- _ -> "less -f"- - (strs, tmps) <- case args of- [fp] | isExtCoreFile fp -> do- contents <- readFile fp- return (contents, Nothing)- _ -> do- strs1 <- compileWithCore (optGhcExe opts)- args (optAsm opts)- let strs2 = polish strs1- let strs3 | optCast opts = strs2- | otherwise = castKill strs2- -- TODO this is a bit lazy on my part...- x <- readProcess "sh" ["-c","ls /tmp/ghc*/*.s | head -1"] []- case x of- Left _ -> return (strs3, Nothing)- Right s -> if "-fvia-C" `elem` args || "-fllvm" `elem` args- then do asm <- readFile (init s)- return ((strs3 ++ asm), Just $ takeDirectory s)- else return (strs3, Just $ takeDirectory s)+ code <- case args of+ [fp] | isExtCoreFile fp -> readFile fp+ _ -> do+ strs <- compileWithCore opts args+ return (polish strs) -{-- -- If we replace the 'NoLit' constructor with 'False' (and- -- remove the include for the Literate type), then this will- -- work with older hscolour-1.10.* versions.- let nice = hscolour- (optFormat opts)- colourPrefs False True NoLit [] strs--}- let nice | optSyntax opts = render ansiLight strs []- | otherwise = strs+ let niceCode | optSyntax opts = render ansiLight code []+ | otherwise = code bracket (openTempFile "/tmp" "ghc-core-XXXX.hcr")- (\(f,h) -> do hClose h- removeFile f- case tmps of- Just g -> system ("rm -rf " ++ g) >> return ()- _ -> return ()- )+ (\(f,h) -> hClose h >> removeFile f) (\(f,h) -> do- hPutStrLn h nice >> hFlush h- e <- system $ less ++ " -r " ++ f+ hPutStrLn h niceCode >> hFlush h+ e <-showInPager f exitWith e) --- --- Clean up the output with some regular expressions. --- +showInPager :: FilePath -> IO ExitCode+showInPager file = do+ mv <- getEnvMaybe "PAGER"+ let pager = fromMaybe "less" mv+ pagerOpts = if pager == "less" then ["-f", "-r"] else []+ rawSystem pager (pagerOpts ++ [file])++--+-- Clean up the output with some regular expressions.+-- polish :: String -> String polish = unlines . dups . map polish' . lines where polish' [] = [] polish' s- | Just [_,a,b] <- match name s [] = polish' (a ++ b)- | Just [_,a,b] <- match local s [] = polish' (a ++ b)- | Just _ <- match core s [] = "------------------------------- Core -----------------------------------"- | Just _ <- match asm s [] = "------------------------------- Assembly -------------------------------"-- | Just _ <- match junk s [] = []- | Just _ <- match junk2 s [] = []- | Just _ <- match junk3 s [] = []- | Just _ <- match junk4 s [] = []- | Just _ <- match junk5 s [] = []- | Just _ <- match junk6 s [] = []- | Just _ <- match junk7 s [] = []-- | otherwise = s+ | Just [_,a,b] <- match name s [] = polish' (a ++ b)+ | Just [_,a,b] <- match local s [] = polish' (a ++ b)+ | isJunk s = ""+ | otherwise = s -- simplify some qualified names name = compile@@ -204,93 +146,45 @@ "^(.*)Main\\.(.*)$" [ungreedy] - -- remove boring things- core = compile "Tidy Core" [ungreedy]- asm = compile "Asm code" [ungreedy]+ isJunk s = any (\r -> isJust (match r s [])) junks - junk = compile "^.GlobalId" []- junk2 = compile "^.Arity .*" []- junk3 = compile "^Rec {|^end Rec" []- junk4 = compile "DmdType" []- junk5 = compile "NoCafRefs" []- junk6 = compile "^\\[\\]$" []- junk7 = compile "==========" []+ junks = map (\r -> compile r [])+ [ "^.GlobalId"+ , "^.Arity .*"+ , "^Rec {|^end Rec"+ , "DmdType"+ , "NoCafRefs"+ , "^\\[\\]$"+ ] -- remove duplicate blank lines dups [] = [] dups ([]:[]:xs) = dups ([]:xs) dups (x:xs) = x : dups xs ------ Eliminate calls to infix cast from output.----castKill :: String -> String-castKill ('`':'c':'a':'s':'t':'`':' ':'(':xs) = parenMunch 1 xs- where- parenMunch :: Int -> String -> String- parenMunch 0 xs = castKill xs- parenMunch n (')':xs) = parenMunch (n-1) xs- parenMunch n ('(':xs) = parenMunch (n+1) xs- parenMunch n (_:xs) = parenMunch n xs-castKill (x:xs) = x : castKill xs-castKill [] = []- ------------------------------------------------------------------------ -compileWithCore :: String -> [String] -> Bool -> IO String-compileWithCore ghc opts asm = do- let args = words $ "-O2 -keep-tmp-files -ddump-simpl -ddump-simpl-stats -fforce-recomp --make" ++ if asm then " -ddump-asm" else ""+compileWithCore :: Options -> [String] -> IO String+compileWithCore opts args = do+ -- TODO: Show generated assembly for -fllvm (previously implemented with+ -- -keep-tmp-files)+ -- TODO: Does -ddump-simpl-stats belong here?+ let defaultArgs = words "-O2 -ddump-simpl -fforce-recomp --make"+ ++ (if optAsm opts then ["-ddump-asm"] else [])+ ++ (if optCast opts then [] else ["-dsuppress-coercions"]) - x <- readProcess ghc (args ++ opts) []+ x <- readProcessWithExitCode (optGhcExe opts) (defaultArgs ++ args) [] case x of- Left (err,str,std) -> do+ (err@(ExitFailure _),str,std) -> do mapM_ putStrLn (lines str) mapM_ putStrLn (lines std)- printf "GHC failed to compile %s\n" (show err)+ hPutStrLn stderr ("GHC failed to compile " ++ show err) exitWith (ExitFailure 1) -- fatal - Right str -> return str+ (ExitSuccess, str, _) -> return str ------------------------------------------------------------------------ ------ Strict process reading ----readProcess :: FilePath -- ^ command to run- -> [String] -- ^ any arguments- -> String -- ^ standard input- -> IO (Either (ExitCode,String,String) String) -- ^ either the stdout, or an exitcode and any output--readProcess cmd args input = handle (return . Left . handler) $ do- (inh,outh,errh,pid) <- runInteractiveProcess cmd args Nothing Nothing-- output <- hGetContents outh- outMVar <- newEmptyMVar- forkIO $ (evaluate (length output) >> putMVar outMVar ())-- errput <- hGetContents errh- errMVar <- newEmptyMVar- forkIO $ (evaluate (length errput) >> putMVar errMVar ())-- when (not (null input)) $ hPutStr inh input- takeMVar outMVar- takeMVar errMVar- ex <- E.catch (waitForProcess pid) (\(_::SomeException) -> return ExitSuccess)- hClose outh- hClose inh -- done with stdin- hClose errh -- ignore stderr-- return $ case ex of- ExitSuccess -> Right output- ExitFailure _ -> Left (ex, errput, output)-- where- handler :: SomeException -> (ExitCode,String,String)- handler ex- | Just (e::ExitCode) <- fromException ex = (e,"","")- | otherwise = (ExitFailure 1, show ex, "")-- -- Safe wrapper for getEnv getEnvMaybe :: String -> IO (Maybe String)-getEnvMaybe name = handle (\(_::SomeException) -> return Nothing) (Just `fmap` getEnv name)+getEnvMaybe name = handle (\(_::SomeException) -> return Nothing) (Just <$> getEnv name)