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.
--
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
......
......@@ -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
......
......@@ -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"
......
......@@ -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 ()
......
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