Fix LLVM version check yet againwip/backport-T16912

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)

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 ()