Commit bf9dfe1c authored by Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan Committed by Marge Bot

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