diff options
author | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2019-08-23 14:43:11 +0300 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-08-29 04:28:35 -0400 |
commit | bf9dfe1ca32270f5e946e0f8ac1bb97184de6e4c (patch) | |
tree | a0b9142a0f43caff401f6b0b1b3af85e70712c28 | |
parent | 66282ba5d7ef0e4f7491464fc05b83e4526c9704 (diff) | |
download | haskell-bf9dfe1ca32270f5e946e0f8ac1bb97184de6e4c.tar.gz |
Fix LLVM version check yet again
There were two problems with LLVM version checking:
- The parser would only parse x and x.y formatted versions. E.g. 1.2.3
would be rejected.
- The version check was too strict and would reject x.y formatted
versions. E.g. when we support version 7 it'd reject 7.0 ("LLVM
version 7.0") and only accept 7 ("LLVM version 7").
We now parse versions with arbitrarily deep minor numbering (x.y.z.t...)
and accept versions as long as the major version matches the supported
version (e.g. 7.1, 7.1.2, 7.1.2.3 ...).
-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 () |