diff options
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen.hs | 28 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/Base.hs | 43 | ||||
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 10 | ||||
| -rw-r--r-- | compiler/main/SysTools/Tasks.hs | 18 |
4 files changed, 52 insertions, 47 deletions
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index f649069b97..399a81b183 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE CPP, TypeFamilies, ViewPatterns #-} +{-# LANGUAGE CPP, TypeFamilies, ViewPatterns, OverloadedStrings #-} -- ----------------------------------------------------------------------------- -- | This is the top-level module in the LLVM code generator. -- -module LlvmCodeGen ( LlvmVersion (..), llvmCodeGen, llvmFixupAsm ) where +module LlvmCodeGen ( LlvmVersion, llvmVersionList, llvmCodeGen, llvmFixupAsm ) where #include "HsVersions.h" @@ -34,7 +34,7 @@ import UniqSupply import SysTools ( figureLlvmVersion ) import qualified Stream -import Control.Monad ( when ) +import Control.Monad ( when, forM_ ) import Data.Maybe ( fromMaybe, catMaybes ) import System.IO @@ -52,21 +52,21 @@ llvmCodeGen dflags h us cmm_stream showPass dflags "LLVM CodeGen" -- get llvm version, cache for later use - ver <- (fromMaybe supportedLlvmVersion) `fmap` figureLlvmVersion dflags + mb_ver <- figureLlvmVersion dflags -- warn if unsupported - debugTraceMsg dflags 2 - (text "Using LLVM version:" <+> text (show ver)) - let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags - when (ver /= supportedLlvmVersion && doWarn) $ - putMsg dflags (text "You are using an unsupported version of LLVM!" - $+$ text ("Currently only " ++ - llvmVersionStr supportedLlvmVersion ++ - " is supported.") - $+$ text "We will try though...") + forM_ mb_ver $ \ver -> do + debugTraceMsg dflags 2 + (text "Using LLVM version:" <+> text (llvmVersionStr ver)) + let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags + when (not (llvmVersionSupported ver) && doWarn) $ putMsg dflags $ + "You are using an unsupported version of LLVM!" $$ + "Currently only " <> text (llvmVersionStr supportedLlvmVersion) <> " is supported." <+> + "System LLVM version: " <> text (llvmVersionStr ver) $$ + "We will try though..." -- run code generation - a <- runLlvm dflags ver bufh us $ + a <- runLlvm dflags (fromMaybe supportedLlvmVersion mb_ver) bufh us $ llvmCodeGen' (liftStream cmm_stream) bFlush bufh diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 7bed4c7b8d..e56be3ebb2 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -13,7 +13,8 @@ module LlvmCodeGen.Base ( LiveGlobalRegs, LlvmUnresData, LlvmData, UnresLabel, UnresStatic, - LlvmVersion (..), supportedLlvmVersion, llvmVersionStr, + LlvmVersion, supportedLlvmVersion, llvmVersionSupported, parseLlvmVersion, + llvmVersionStr, llvmVersionList, LlvmM, runLlvm, liftStream, withClearVars, varLookup, varInsert, @@ -60,6 +61,9 @@ import qualified Stream import Data.Maybe (fromJust) import Control.Monad (ap) +import Data.Char (isDigit) +import Data.List (intercalate) +import qualified Data.List.NonEmpty as NE -- ---------------------------------------------------------------------------- -- * Some Data Types @@ -176,26 +180,35 @@ llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags -- * Llvm Version -- --- | LLVM Version Number -data LlvmVersion - = LlvmVersion Int - | LlvmVersionOld Int Int - deriving Eq +-- Newtype to avoid using the Eq instance! +newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int } --- Custom show instance for backwards compatibility. -instance Show LlvmVersion where - show (LlvmVersion maj) = show maj - show (LlvmVersionOld maj min) = show maj ++ "." ++ show min +parseLlvmVersion :: String -> Maybe LlvmVersion +parseLlvmVersion = + fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit) + where + go vs s + | null ver_str + = reverse vs + | '.' : rest' <- rest + = go (read ver_str : vs) rest' + | otherwise + = reverse (read ver_str : vs) + where + (ver_str, rest) = span isDigit s -- | The LLVM Version that is currently supported. supportedLlvmVersion :: LlvmVersion -supportedLlvmVersion = LlvmVersion sUPPORTED_LLVM_VERSION +supportedLlvmVersion = LlvmVersion (sUPPORTED_LLVM_VERSION NE.:| []) + +llvmVersionSupported :: LlvmVersion -> Bool +llvmVersionSupported (LlvmVersion v) = NE.head v == sUPPORTED_LLVM_VERSION llvmVersionStr :: LlvmVersion -> String -llvmVersionStr v = - case v of - LlvmVersion maj -> show maj - LlvmVersionOld maj min -> show maj ++ "." ++ show min +llvmVersionStr = intercalate "." . map show . llvmVersionList + +llvmVersionList :: LlvmVersion -> [Int] +llvmVersionList = NE.toList . llvmVersionNE -- ---------------------------------------------------------------------------- -- * Environment Handling diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index c33fca6003..03a55aef02 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -56,7 +56,7 @@ import StringBuffer ( hGetStringBuffer, hPutStringBuffer ) import BasicTypes ( SuccessFlag(..) ) import Maybes ( expectJust ) import SrcLoc -import LlvmCodeGen ( LlvmVersion (..), llvmFixupAsm ) +import LlvmCodeGen ( llvmFixupAsm, llvmVersionList ) import MonadUtils import GHC.Platform import TcRnTypes @@ -2039,10 +2039,10 @@ doCpp dflags raw input_fn output_fn = do getBackendDefs :: DynFlags -> IO [String] getBackendDefs dflags | hscTarget dflags == HscLlvm = do llvmVer <- figureLlvmVersion dflags - return $ case llvmVer of - Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ] - Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] - _ -> [] + return $ case fmap llvmVersionList llvmVer of + Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ] + Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] + _ -> [] where format (major, minor) | minor >= 100 = error "getBackendDefs: Unsupported minor version" diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs index eeaadfa5b8..9ee3ba467c 100644 --- a/compiler/main/SysTools/Tasks.hs +++ b/compiler/main/SysTools/Tasks.hs @@ -16,14 +16,13 @@ import Outputable import GHC.Platform import Util -import Data.Char import Data.List import System.IO import System.Process import GhcPrelude -import LlvmCodeGen.Base (LlvmVersion (..), llvmVersionStr, supportedLlvmVersion) +import LlvmCodeGen.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersion, parseLlvmVersion) import SysTools.Process import SysTools.Info @@ -209,7 +208,7 @@ figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do -- of the options they've specified. llc doesn't care what other -- options are specified when '-version' is used. args' = args ++ ["-version"] - ver <- catchIO (do + catchIO (do (pin, pout, perr, _) <- runInteractiveProcess pgm args' Nothing Nothing {- > llc -version @@ -219,18 +218,12 @@ figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do -} hSetBinaryMode pout False _ <- hGetLine pout - vline <- dropWhile (not . isDigit) `fmap` hGetLine pout - v <- case span (/= '.') vline of - ("",_) -> fail "no digits!" - (x,"") -> return $ LlvmVersion (read x) - (x,y) -> return $ LlvmVersionOld - (read x) - (read $ takeWhile isDigit $ drop 1 y) - + vline <- hGetLine pout + let mb_ver = parseLlvmVersion vline hClose pin hClose pout hClose perr - return $ Just v + return mb_ver ) (\err -> do debugTraceMsg dflags 2 @@ -242,7 +235,6 @@ figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do text ("Make sure you have installed LLVM " ++ llvmVersionStr supportedLlvmVersion) ] return Nothing) - return ver runLink :: DynFlags -> [Option] -> IO () |