disasm-test: Overhaul treatment of LLVM version ranges

disasm-test/Main.hs

@@ -1,5 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -10,13 +9,15 @@ import qualified Text.LLVM.AST as AST
 import           Text.LLVM.PP (ppLLVM,ppModule)
 
 import qualified Control.Exception as X
-import           Control.Lens ((^.), (^?), _Right, to)
-import           Control.Monad (unless, when)
+import           Control.Lens ( (^?), _Right )
+import           Control.Monad ( unless, when )
+import           Control.Monad.IO.Class ( liftIO )
 import           Data.Bifunctor (first)
 import qualified Data.ByteString.Lazy as L
 import           Data.Char (ord,isLetter,isSpace,chr)
+import           Data.Functor ( (<&>) )
 import           Data.Generics (everywhere, mkT) -- SYB
-import           Data.List (isInfixOf, sort, stripPrefix)
+import           Data.List ( isInfixOf, sort )
 import           Data.Proxy ( Proxy(..) )
 import qualified Data.Text as T
 import           Data.Typeable (Typeable)
@@ -25,16 +26,16 @@ import qualified GHC.IO.Exception as GE
 import qualified Options.Applicative as OA
 import           System.Directory (getTemporaryDirectory, removeFile)
 import           System.Exit (ExitCode(..), exitFailure, exitSuccess)
-import           System.FilePath ((<.>))
+import           System.FilePath ( (<.>) )
+import           System.IO (openBinaryTempFile,hClose,openTempFile,hPutStrLn)
 import qualified System.IO as IO (stderr)
-import           System.IO
-    (openBinaryTempFile,hClose,openTempFile,hPutStrLn)
 import qualified System.Process as Proc
 import           Test.Tasty
 import           Test.Tasty.HUnit ( assertFailure, testCase )
 import qualified Test.Tasty.Options as TO
 import qualified Test.Tasty.Runners as TR
 import qualified Test.Tasty.Sugar as TS
+import           Text.Read (readMaybe)
 import           Text.Show.Pretty (ppShow)
 
 
@@ -91,22 +92,35 @@ disasmTestIngredients =
                    , TO.Option (Proxy @Roundtrip)
                    , TO.Option (Proxy @Keep)
                    ] :
-  defaultIngredients
+  TS.sugarIngredients [cube]
+  <> defaultIngredients
+
+parseCmdLine :: IO TO.OptionSet
+parseCmdLine = do
+  TR.installSignalHandlers
+  let disasmOptDescrs = TO.uniqueOptionDescriptions $
+        TR.coreOptions ++
+        TS.sugarOptions ++
+        TR.ingredientsOptions disasmTestIngredients
+      (disasmOptWarns, disasmOptParser) = TR.optionParser disasmOptDescrs
+  mapM_ (hPutStrLn IO.stderr) disasmOptWarns
+  OA.execParser $
+    OA.info (OA.helper <*> disasmOptParser)
+    ( OA.fullDesc <>
+      OA.header "llvm-pretty-bc-parser disassembly test suite"
+    )
+
 
 -- Querying Tool Versions ------------------------------------------------------
 
--- lack of decipherable version is not fatal to running the tests
+-- | Captures the name of the tool and either the error when attempting to get
+-- the tool version or the actual parsed version self-reported by the tool.  Lack
+-- of a decipherable version is not fatal to running the tests.
 data VersionCheck = VC String (Either T.Text Versioning)
 
 showVC :: VersionCheck -> String
 showVC (VC nm v) = nm <> " " <> (T.unpack $ either id prettyV v)
 
-vcTag :: VersionCheck -> String
-vcTag v@(VC nm _) = nm <> vcMajor v
-
-vcMajor :: VersionCheck -> String
-vcMajor (VC _ v) = either T.unpack (^. major . to show) v
-
 vcVersioning :: VersionCheck -> Either T.Text Versioning
 vcVersioning (VC _ v) = v
 
@@ -119,10 +133,9 @@ getLLVMAsVersion (LLVMAs llvmAsPath) = getLLVMToolVersion "llvm-as" llvmAsPath
 getLLVMDisVersion :: LLVMDis -> IO VersionCheck
 getLLVMDisVersion (LLVMDis llvmDisPath) = getLLVMToolVersion "llvm-dis" llvmDisPath
 
--- Determine which version of an LLVM tool will be used for these tests.
--- An exception (e.g. in readProcess if the tool is not found) will
--- result in termination (test failure). Uses partial 'head' but
--- this is just tests, and failure is captured.
+-- Determine which version of an LLVM tool will be used for these tests (if
+-- possible).  Uses partial 'head' but this is just tests, and failure is
+-- captured.
 getLLVMToolVersion :: String -> FilePath -> IO VersionCheck
 getLLVMToolVersion toolName toolPath = do
   let isVerLine = isInfixOf "LLVM version"
@@ -133,6 +146,9 @@ getLLVMToolVersion toolName toolPath = do
       getVer (Left full) = full
   mkVC toolName . getVer <$> readProcessVersion toolPath
 
+-- Runs the tool with a --version argument to have it self-report its version.
+-- The tool may not even be installed.  Returns either an error string or the
+-- output string from the tool.
 readProcessVersion :: String -> IO (Either String String)
 readProcessVersion forTool =
   X.catches (Right <$> Proc.readProcess forTool [ "--version" ] "")
@@ -160,17 +176,7 @@ main =  do
   -- `defaultMainWithIngredients` invocation doesn't allow you to
   -- generate a dynamic number of tests in IO based on argument values. As a
   -- result, we have to resort to using more of tasty's internals here.
-  TR.installSignalHandlers
-  let disasmOptDescrs = TO.uniqueOptionDescriptions $
-        TR.coreOptions ++
-        TR.ingredientsOptions disasmTestIngredients
-      (disasmOptWarns, disasmOptParser) = TR.optionParser disasmOptDescrs
-  mapM_ (hPutStrLn IO.stderr) disasmOptWarns
-  disasmOpts <- OA.execParser $
-    OA.info (OA.helper <*> disasmOptParser)
-    ( OA.fullDesc <>
-      OA.header "llvm-pretty-bc-parser disassembly test suite"
-    )
+  disasmOpts <- parseCmdLine
 
   let llvmAs  = TO.lookupOption disasmOpts
       llvmDis = TO.lookupOption disasmOpts
@@ -185,7 +191,7 @@ main =  do
       ]
 
   sweets <- TS.findSugar cube
-  tests <- TS.withSugarGroups sweets testGroup $ \s _ e -> runTest llvmAsVC s e
+  tests <- TS.withSugarGroups sweets testGroup $ \s _ e -> runTest s e
   case TR.tryIngredients
          disasmTestIngredients
          disasmOpts
@@ -205,10 +211,10 @@ cube = TS.mkCUBE
   { TS.inputDirs = ["disasm-test/tests"]
   , TS.rootName = "*.ll"
   , TS.separators = "."
-  , TS.validParams = [ ("llvm-range", Just [ "pre-llvm11"
-                                           , "at-least-llvm12"
-                                           , "at-least-llvm13"
-                                           , "at-least-llvm14"
+  , TS.validParams = [ ("llvm-range", Just [ "recent-llvm"
+                                           , "pre-llvm12"
+                                           , "pre-llvm13"
+                                           , "pre-llvm14"
                                            ])
                      ]
     -- Somewhat unusually for tasty-sugar, we make the expectedSuffix the same
@@ -217,6 +223,24 @@ cube = TS.mkCUBE
     -- llvm-pretty-bc-parser, pretty-printing it with llvm-pretty, and
     -- then normalizing it. As such, each .ll file acts as its own golden file.
   , TS.expectedSuffix = "ll"
+  , TS.sweetAdjuster = \cb swts -> do
+      -- Performed ranged-matching of the llvm-range parameter against the
+      -- version of llvm (reported by llvm-as) to filter the tasty-sugar
+      -- expectations.
+      disasmOpts <- liftIO parseCmdLine
+      llvmver <- liftIO $ getLLVMAsVersion $ TO.lookupOption disasmOpts
+      ss <- TS.rangedParamAdjuster "llvm-range"
+            (readMaybe . drop (length ("pre-llvm" :: String)))
+            (<)
+            (vcVersioning llvmver ^? (_Right . major))
+            cb swts
+      -- In addition, this is a round-trip test (assemble + disassemble) where
+      -- the rootname is the same as the expected name.  Filter out any
+      -- expectations that don't match the root name.
+      -- (e.g. remove: root=poison.ll with exp=poison.pre-llvm12.ll).
+      let rootExpSame s e = TS.rootFile s == TS.expectedFile e
+      return $ ss
+        <&> \s -> s { TS.expected = filter (rootExpSame s) $ TS.expected s }
   }
 
 -- | A test failure.
@@ -227,46 +251,50 @@ data TestFailure
 instance X.Exception TestFailure
 
 -- | Attempt to compare the assembly generated by llvm-pretty and llvm-dis.
-runTest :: VersionCheck -> TS.Sweets -> TS.Expectation -> IO [TestTree]
-runTest llvmVer sweet expct
-  | not llvmMatch
-  = pure []
-  | otherwise
-  = pure $ (:[]) $
-    askOption $ \llvmAs ->
-    askOption $ \llvmDis ->
-    askOption $ \roundtrip ->
-    askOption $ \k@(Keep keep) ->
-    testCase pfx $ do
-
-      let -- Assemble and disassemble some LLVM asm
-          processLL :: FilePath -> IO (FilePath, Maybe FilePath)
-          processLL f = do
-            putStrLn (showString f ": ")
-            X.handle logError                               $
-              withFile  (generateBitCode    llvmAs  pfx f)  $ \ bc   ->
-              withFile  (normalizeBitCode k llvmDis pfx bc) $ \ norm -> do
-                (parsed, ast) <- processBitCode k roundtrip pfx bc
-                ignore (Proc.callProcess "diff" ["-u", norm, parsed])
-                putStrLn ("successfully parsed " ++ show f)
-                return (parsed, ast)
-
-          withFile :: IO FilePath -> (FilePath -> IO r) -> IO r
-          withFile iofile f =
-            X.bracket iofile (if keep then const (pure ()) else removeFile) f
-
-      (parsed1, ast) <- processLL file
-      case ast of               -- this Maybe also encodes the data of optRoundtrip
-        Nothing   -> return ()
-        Just ast1 -> do
-          (_, Just ast2) <- processLL parsed1 -- Re-assemble and re-disassemble
-          diff ast1 ast2                      -- Ensure that the ASTs match
-          -- Ensure that the disassembled files match.
-          -- This is usually too strict (and doesn't really provide more info).
-          -- We normalize the AST (see below) to ensure that the ASTs match modulo
-          -- metadata numbering, but the equivalent isn't possible for the
-          -- assembly: we need llvm-as to be able to re-assemble it.
-          -- diff parsed1 parsed2
+runTest :: TS.Sweets -> TS.Expectation -> IO [TestTree]
+runTest sweet expct
+  = do -- If an .ll file begins with SKIP_TEST, skip that test entirely. For
+       -- test cases that require a minimum LLVM version, this technique is
+       -- used to prevent running the test on older LLVM versions.
+       skipTest <- ("SKIP_TEST" `L.isPrefixOf`) <$> L.readFile (TS.expectedFile expct)
+
+       if skipTest
+         then pure []
+         else pure $ (:[]) $
+           askOption $ \llvmAs ->
+           askOption $ \llvmDis ->
+           askOption $ \roundtrip ->
+           askOption $ \k@(Keep keep) ->
+           testCase pfx $ do
+
+             let -- Assemble and disassemble some LLVM asm
+                 processLL :: FilePath -> IO (FilePath, Maybe FilePath)
+                 processLL f = do
+                   putStrLn (showString f ": ")
+                   X.handle logError                               $
+                     withFile  (generateBitCode    llvmAs  pfx f)  $ \ bc   ->
+                     withFile  (normalizeBitCode k llvmDis pfx bc) $ \ norm -> do
+                       (parsed, ast) <- processBitCode k roundtrip pfx bc
+                       ignore (Proc.callProcess "diff" ["-u", norm, parsed])
+                       putStrLn ("successfully parsed " ++ show f)
+                       return (parsed, ast)
+
+                 withFile :: IO FilePath -> (FilePath -> IO r) -> IO r
+                 withFile iofile f =
+                   X.bracket iofile (if keep then const (pure ()) else removeFile) f
+
+             (parsed1, ast) <- processLL file
+             case ast of               -- this Maybe also encodes the data of optRoundtrip
+               Nothing   -> return ()
+               Just ast1 -> do
+                 (_, Just ast2) <- processLL parsed1 -- Re-assemble and re-disassemble
+                 diff ast1 ast2                      -- Ensure that the ASTs match
+                 -- Ensure that the disassembled files match.
+                 -- This is usually too strict (and doesn't really provide more info).
+                 -- We normalize the AST (see below) to ensure that the ASTs match modulo
+                 -- metadata numbering, but the equivalent isn't possible for the
+                 -- assembly: we need llvm-as to be able to re-assemble it.
+                 -- diff parsed1 parsed2
   where file  = TS.rootFile sweet
         pfx   = TS.rootBaseName sweet
         assertF ls = assertFailure $ unlines ls
@@ -283,37 +311,6 @@ runTest llvmVer sweet expct
               then assertF ["non-empty diff", stdout, stderr]
               else mapM_ putStrLn ["success: empty diff: ", file1, file2]
 
-        -- Match any LLVM version range specification in the .ll
-        -- expected file against the current version of the LLVM tools. If the
-        -- current LLVM version doesn't match, no test should be
-        -- generated (i.e. only run tests for the version of LLVM tools
-        -- available).
-        llvmMatch =
-          let specMatchesInstalled v =
-                or [ v == vcTag llvmVer
-                   , and [ v == "pre-llvm11"
-                         , vcMajor llvmVer `elem` (show <$> [3..10 :: Int])
-                         ]
-                   , case stripPrefix "at-least-llvm" v of
-                       Nothing -> False
-                       Just verStr ->
-                         (vcVersioning llvmVer ^? (_Right . major)) >= Just (read verStr)
-                     -- as a fallback, if the testing code here is
-                     -- unable to determine the version, run all
-                     -- tests. This is likely to cause a failure, but
-                     -- is preferable to running no tests, which
-                     -- results in a success report without having
-                     -- done anything.
-                   , vcMajor llvmVer == "[missing]"
-                   ]
-          in case lookup "llvm-range" (TS.expParamsMatch expct) of
-               Just (TS.Explicit v) -> specMatchesInstalled v
-               Just (TS.Assumed v)
-                 |  v == "pre-llvm11" || v == "at-least-llvm12"
-                 -> specMatchesInstalled v
-                 |  otherwise
-                 -> False
-               _ -> error "llvm-range unknown"
 
 -- | Assemble some llvm assembly, producing a bitcode file in /tmp.
 generateBitCode :: LLVMAs -> FilePath -> FilePath -> IO FilePath

disasm-test/README.md

@@ -0,0 +1,45 @@
+# `disasm-test`
+
+This test suite ensures that for each `.ll` file under the `tests` directory:
+
+1. After using `llvm-as` to produce a `.bc` file, the `.bc` file can be parsed
+   using `llvm-pretty-bc-parser`.
+2. The resulting `llvm-pretty` AST can be pretty-printed back out to an `.ll`
+   file using `llvm-pretty`'s pretty-printer.
+3. The new `.ll` file is mostly equivalent to the original `.ll` file.
+
+Here, "mostly equivalent" means that the two files are syntactically
+equivalent, ignoring minor differences in whitespace and the order of metadata
+in the metadata list.
+
+## Conditional tests
+
+Some of the test cases have slightly different bitcode depending on which LLVM
+version is used. These test cases will have accompanying
+`<test-case>.pre-llvm<version>.ll` files, where `pre-llvm<version>` indicates
+that this test output is used for all LLVM versions up to (but not including)
+`<version>`. Note that if a test case has multiple `pre-llvm<version>.ll`
+files, then the `<version>` that is closest to the current LLVM version
+(without going over) is picked.
+
+To illustrate this with a concrete example, consider suppose we have a test
+case `foo` with the following `.ll` files
+
+* `foo.pre-llvm11.ll`
+* `foo.pre-llvm13.ll`
+* `foo.ll`
+
+The following `.ll` files would be used for the following LLVM versions:
+
+* LLVM 10: `foo.pre-llvm11.ll`
+* LLVM 11: `foo.pre-llvm13.ll`
+* LLVM 12: `foo.pre-llvm13.ll`
+* LLVM 13 or later: `foo.ll`
+
+There are some test cases that require a sufficiently recent LLVM version to
+run. To indicate that a test should not be run on LLVMs older than `<version>`,
+create a `pre-llvm<version>.ll` file with `SKIP_TEST` as the first line. The
+use of `SKIP_TEST` signals that this test should be skipped when using LLVMs
+older than `<version>`. Note that the test suite will not read anything past
+`SKIP_TEST`, so the rest of the file can be used to document why the test is
+skipped on that particular configuration.

disasm-test/tests/btf-tag-dicompositetype.pre-llvm14.ll

@@ -0,0 +1 @@
+SKIP_TEST

disasm-test/tests/btf-tag-diderivedtype.pre-llvm14.ll

@@ -0,0 +1 @@
+SKIP_TEST

disasm-test/tests/btf-tag-diglobalvariable.pre-llvm14.ll

@@ -0,0 +1 @@
+SKIP_TEST

disasm-test/tests/btf-tag-dilocalvariable.pre-llvm14.ll

@@ -0,0 +1 @@
+SKIP_TEST

disasm-test/tests/btf-tag-disubprogram.pre-llvm14.ll

@@ -0,0 +1 @@
+SKIP_TEST

disasm-test/tests/di-arg-list.pre-llvm13.ll

@@ -0,0 +1 @@
+SKIP_TEST

disasm-test/tests/dilocalvariable.pre-llvm14.ll

@@ -0,0 +1 @@
+SKIP_TEST

disasm-test/tests/poison.pre-llvm12.ll

@@ -0,0 +1 @@
+SKIP_TEST

llvm-pretty-bc-parser.cabal

@@ -122,6 +122,7 @@ Test-suite disasm-test
   hs-source-dirs:      disasm-test
   Ghc-options:         -Wall
   build-depends:       base,
+                       containers,
                        process,
                        directory,
                        bytestring,
@@ -132,9 +133,9 @@ Test-suite disasm-test
                        syb        >= 0.7,
                        tasty >= 1.3,
                        tasty-hunit,
-                       tasty-sugar >= 2.1 && < 2.2,
+                       tasty-sugar >= 2.2 && < 2.3,
                        text,
-                       versions,
+                       versions < 6,
                        llvm-pretty,
                        llvm-pretty-bc-parser