From e4ee13d0c9b7b50c64e5ccf004b15c253ebfb28c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=96mer=20Sinan=20A=C4=9Facan?= Date: Fri, 23 Aug 2019 14:43:11 +0300 Subject: 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 ...). (cherry picked from commit bf9dfe1ca32270f5e946e0f8ac1bb97184de6e4c) --- compiler/llvmGen/LlvmCodeGen.hs | 28 +++++++++++------------ compiler/llvmGen/LlvmCodeGen/Base.hs | 43 +++++++++++++++++++++++------------- compiler/main/DriverPipeline.hs | 10 ++++----- 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 4790e91425..8b374c7b0e 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 - runLlvm dflags ver bufh us $ + 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 e02ff7efae..d6e9a1c634 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -12,7 +12,8 @@ module LlvmCodeGen.Base ( LiveGlobalRegs, LlvmUnresData, LlvmData, UnresLabel, UnresStatic, - LlvmVersion (..), supportedLlvmVersion, llvmVersionStr, + LlvmVersion, supportedLlvmVersion, llvmVersionSupported, parseLlvmVersion, + llvmVersionStr, llvmVersionList, LlvmM, runLlvm, liftStream, withClearVars, varLookup, varInsert, @@ -58,6 +59,9 @@ import ErrUtils import qualified Stream import Control.Monad (ap) +import Data.Char (isDigit) +import Data.List (intercalate) +import qualified Data.List.NonEmpty as NE -- ---------------------------------------------------------------------------- -- * Some Data Types @@ -175,26 +179,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 ef6152430d..bf79ea5d02 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 Platform import TcRnTypes @@ -2170,10 +2170,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 45d2efbbbf..45ca73bcf9 100644 --- a/compiler/main/SysTools/Tasks.hs +++ b/compiler/main/SysTools/Tasks.hs @@ -15,14 +15,13 @@ import Outputable import 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 @@ -193,7 +192,7 @@ figureLlvmVersion dflags = 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 @@ -203,18 +202,12 @@ figureLlvmVersion dflags = 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 @@ -226,7 +219,6 @@ figureLlvmVersion dflags = do text ("Make sure you have installed LLVM " ++ llvmVersionStr supportedLlvmVersion) ] return Nothing) - return ver runLink :: DynFlags -> [Option] -> IO () -- cgit v1.2.1