Merge branch 'factor-out-default-interpreter' into 'master'

Factor out default interpreter

Closes #3

See merge request !7

README.mkd

@@ -19,6 +19,12 @@ There is a convenient script, `run.sh`, which handles this for you; just set
 the `BOOT_GHC` environment variable to the bootstrap compiler and `TEST_GHC` to
 the compiler-under-test.
 
+## Usage with cross-compilers
+
+`test-primops` can test cross-compilers by running `run.sh` with `TEST_GHC` set
+to the path to the cross-compiler and `EMULATOR` to the path to an emulator
+which can run a target executable (e.g. `qemu-user` or `wasmtime`).
+
 ## REPL usage
 
 It can often be useful to load the `test-primops` executable into GHCi.

run.sh

@@ -5,6 +5,7 @@ set -e -o pipefail
 BOOT_GHC="${BOOT_GHC:-ghc}"
 TEST_GHC="${TEST_GHC:-ghc}"
 CABAL="${CABAL:-cabal}"
+EMULATOR="${EMULATOR:-}"
 
 build_runit() {
     ALLOW_NEWER="--allow-newer=base"
@@ -15,10 +16,14 @@ build_runit() {
 
 run() {
     build_runit
-    "$CABAL" run -w "$BOOT_GHC" test-primops -- \
-        --ghc-path="$TEST_GHC" \
-        --run-it-path="$RUNIT" \
-        "$@"
+    args=(
+        "--ghc-path=$TEST_GHC"
+        "--run-it-path=$RUNIT"
+    )
+    if [[ -n "$EMULATOR" ]]; then
+        args+=( "--emulator=$EMULATOR" )
+    fi
+    "$CABAL" run -w "$BOOT_GHC" test-primops -- "${args[@]}" "$@"
 }
 
 repl() {

src/CCall.hs

@@ -2,11 +2,9 @@
 module CCall
     ( CCallDesc(..)
     , testCCall
+    , evalCCall
     ) where
 
-import Numeric.Natural
-import System.FilePath
-import System.IO.Temp
 import Test.QuickCheck
 
 import Expr
@@ -14,10 +12,12 @@ import Width
 import ToCmm
 import RunGhc
 import Number
+import Compiler
 
 data CCallDesc
     = CCallDesc { callRet :: SomeNumber
-                , callArgs :: [SomeNumber]
+                , callRetSignedness :: Signedness
+                , callArgs :: [(Signedness, SomeNumber)]
                 }
     deriving (Show)
 
@@ -30,29 +30,36 @@ mAX_ARGS = 32
 instance Arbitrary CCallDesc where
     arbitrary = do
         ret <- arbitrary
+        ret_signedness <- arbitrary
         n <- chooseInt (0, mAX_ARGS)
         args <- vectorOf n arbitrary
-        return $ CCallDesc ret args
+        return $ CCallDesc ret ret_signedness args
+    shrink (CCallDesc ret ret_s args) =
+        CCallDesc <$> shrink ret <*> pure ret_s <*> shrinkList shrink args
+
+evalCCall
+    :: EvalMethod
+    -> CCallDesc
+    -> IO [Integer]
+evalCCall em c = do
+    cProg <- compileC (compiler em) (cStub c)
+    cmmProg <- compileCmm (compiler em) (cCallCmm c)
+    out <- runTestProgram em (cProg <> cmmProg)
+    let saw :: [Integer]
+        saw = map read (lines out)
+    return saw
 
 testCCall
-    :: Compiler
+    :: EvalMethod
     -> CCallDesc
     -> Property
-testCCall comp c = 
-    ioProperty $ withTempDirectory "." "tmp" $ \tmpDir -> do
-        writeFile (tmpDir </> "test_c.c") (cStub c)
-        writeFile (tmpDir </> "test.cmm") (cCallCmm c)
-        compile comp tmpDir ["test_c.c", "test.cmm"] soName ["-shared", "-dynamic"]
-        out <- runIt comp (tmpDir </> soName)
-        let saw :: [Natural]
-            saw = map read (lines out)
-            expected :: [Natural]
-            expected = map (\(SomeNumber e) -> toUnsigned e) (callArgs c) ++ [ret]
-            ret = case callRet c of SomeNumber n -> toUnsigned n
-        return $ saw === expected
-
-  where
-    soName = "test.so"
+testCCall em c = ioProperty $ do
+    saw <- evalCCall em c
+    let expected :: [Integer]
+        expected = map (\(s, SomeNumber e) -> asInteger s e) (callArgs c) ++ [ret]
+        -- The wrapper zero extends the result so interpret it as unsigned.
+        ret = case callRet c of SomeNumber n -> asInteger Unsigned n
+    return $ saw === expected
 
 cStub :: CCallDesc -> String
 cStub c
@@ -65,11 +72,14 @@ cStub c
     ]
   where
     argBndrs = [ "arg"++show i | (i,_) <- zip [0::Int ..] (callArgs c) ]
-    argWidths = [ knownWidth @w | SomeNumber (_ :: Number w) <- callArgs c ]
+    argTypes =
+      [ (signedness, knownWidth @w)
+      | (signedness, SomeNumber (_ :: Number w)) <- callArgs c
+      ]
 
     funcDef = unlines $
-      [ cType (retWidth c) <> " test_c(" <> argList <> ") {" ] ++
-      zipWith printArg argWidths argBndrs ++
+      [ cType Unsigned (retWidth c) <> " test_c(" <> argList <> ") {" ] ++
+      zipWith printArg argTypes argBndrs ++
       [ "  fflush(stdout);"
       , "  return " ++ show (someNumberToUnsigned $ callRet c) ++ "ULL;"
       , "}"
@@ -77,39 +87,50 @@ cStub c
 
     argList =
         commaList
-        [ unwords [cType w, bndr]
-        | (w, bndr) <- zip argWidths argBndrs
+        [ unwords [ty, bndr]
+        | (ty, bndr) <- zip (map (uncurry cType) argTypes) argBndrs
         ]
-    printArg w bndr =
-        "  printf(" ++ quoted (formatStr w ++ "\\n") ++ ", " ++ bndr ++ ");"
+    printArg ty bndr =
+        "  printf(" ++ quoted (formatStr ty ++ "\\n") ++ ", " ++ bndr ++ ");"
 
 quoted :: String -> String
 quoted s = "\"" ++ s ++ "\""
 
-formatStr :: Width -> String
-formatStr w =
-    "0x%" ++ quoted ("PRIx"++show n)
+formatStr :: (Signedness, Width) -> String
+formatStr (signedness, w) =
+    "%" ++ quoted ("PRI" ++ fmt ++ show n)
   where
+    fmt = case signedness of
+            Signed   -> "d"
+            Unsigned -> "u"
     n = widthBits w
 
-cType :: Width -> String
-cType W8  = "uint8_t"
-cType W16 = "uint16_t"
-cType W32 = "uint32_t"
-cType W64 = "uint64_t"
+cType :: Signedness -> Width -> String
+cType signedness width  = prefix ++ "int" ++ show n ++ "_t"
+  where
+    n = widthBits width
+    prefix = case signedness of
+      Signed   -> ""
+      Unsigned -> "u"
 
 cCallCmm :: CCallDesc -> String
 cCallCmm c = unlines
     [ "test("++cmmWordType ++" buffer) {"
     , "  "++cmmType (retWidth c)++" ret;"
-    , "  (ret) = foreign \"C\" test_c(" ++ argList ++ ");"
+    , "  (" ++ retHint ++ "ret) = foreign \"C\" test_c(" ++ argList ++ ");"
     , "  return ("++widenOp++"(ret));"
     , "}"
     ]
   where
+    retHint = case callRetSignedness c of
+                Signed   -> "\"signed\" "
+                Unsigned -> ""
     widenOp = "%zx" ++ show (widthBits wordSize)
     argList =
         commaList
-        [ exprToCmm $ ELit e
-        | SomeNumber e <- callArgs c
+        [ exprToCmm (ELit e) ++ hint
+        | (signedness, SomeNumber e) <- callArgs c
+        , let hint = case signedness of
+                       Signed -> " \"signed\""
+                       Unsigned -> ""
         ]

src/CallishOp.hs

@@ -24,8 +24,8 @@ import ToCmm
 import Number
 import Expr
 
-prop_callish_ops_correct :: Compiler -> TestTree
-prop_callish_ops_correct comp = testGroup "callish ops"
+prop_callish_ops_correct :: EvalMethod -> TestTree
+prop_callish_ops_correct em = testGroup "callish ops"
     [ testCallishOp "popcnt" (\(_ :: Proxy w) -> toProp $ popcnt @w)
     , testCallishOp "pdep"   (\(_ :: Proxy w) -> toProp $ pdep @w)
     , testCallishOp "pext"   (\(_ :: Proxy w) -> toProp $ pext @w)
@@ -34,7 +34,7 @@ prop_callish_ops_correct comp = testGroup "callish ops"
     toProp :: forall args. (CmmArgs args, Arbitrary args, Show args)
            => CallishOp args WordSize
            -> Property
-    toProp op = property $ prop_callish_correct comp op
+    toProp op = property $ prop_callish_correct em op
 
     testCallishOp
         :: String
@@ -92,12 +92,12 @@ fromBits bits = foldl' (.|.) 0 [ bit i | (i, True) <- zip [0..] bits ]
 
 prop_callish_correct
     :: forall args. (CmmArgs args)
-    => Compiler
+    => EvalMethod
     -> CallishOp args WordSize
     -> args
     -> Property
-prop_callish_correct comp op args = counterexample (evalCallishOpCmm op args) $ ioProperty $ do
-    r <- evalCallishOp comp op args
+prop_callish_correct em op args = counterexample (evalCallishOpCmm op args) $ ioProperty $ do
+    r <- evalCallishOp em op args
     return $ refImpl op args === r
 
 data CallishOp args result
@@ -116,12 +116,12 @@ instance (KnownWidth w) => CmmArgs (Expr w) where
 
 evalCallishOp
     :: forall args. (CmmArgs args)
-    => Compiler
+    => EvalMethod
     -> CallishOp args WordSize
     -> args
     -> IO (Number WordSize)
-evalCallishOp comp op args =
-    fromUnsigned <$> evalCmm comp (evalCallishOpCmm op args)
+evalCallishOp em op args =
+    fromUnsigned <$> evalCmm em (evalCallishOpCmm op args)
 
 evalCallishOpCmm
     :: forall args. (CmmArgs args)

src/Compiler.hs

+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Compiler
+    ( Compiler(..)
+    , addArgs
+    , compile
+      -- * Compiling objects
+    , compileC
+    , compileCmm
+    , compileHs
+      -- * Test programs
+    , TestProgram
+    , writeObjectsIn
+    ) where
+
+import qualified Data.ByteString as BS
+import System.Exit
+import System.Process
+import System.IO.Temp
+import System.FilePath
+
+-- | The location of GHC and arguments to pass it.
+data Compiler = Compiler { compPath :: FilePath
+                         , compArgs :: [String]
+                         }
+    deriving (Show)
+
+addArgs :: Compiler -> [String] -> Compiler
+addArgs c args = c { compArgs = compArgs c ++ args }
+
+-- | Compile a set of compilation units.
+compile :: Compiler
+        -> FilePath   -- ^ working directory
+        -> [FilePath] -- ^ sources
+        -> FilePath   -- ^ output path
+        -> [String]   -- ^ other arguments
+        -> IO ()
+compile comp workDir srcs out args = do
+    runProcess' $ inTmp (proc (compPath comp) allArgs)
+  where
+    allArgs = compArgs comp ++ srcs ++ args ++ ["-o", out]
+    inTmp c = c { cwd = Just workDir }
+    runProcess' p = do
+        (_, _, _, hdl) <- createProcess p
+        ExitSuccess <- waitForProcess hdl
+        return ()
+
+compileHs :: Compiler -> String -> IO TestProgram
+compileHs = compileOne "hs"
+
+compileCmm :: Compiler -> String -> IO TestProgram
+compileCmm = compileOne "cmm"
+
+compileC :: Compiler -> String -> IO TestProgram
+compileC = compileOne "c"
+
+compileOne :: String -> Compiler -> String -> IO TestProgram
+compileOne ext comp contents = withTempDirectory "." "tmp" $ \tmpDir -> do
+    writeFile (tmpDir </> srcName) contents
+    compile comp tmpDir [srcName] objName ["-c"]
+    obj <- BS.readFile (tmpDir </> objName)
+    return (TestProgram [obj])
+  where
+    srcName = "test" <.> ext
+    objName = "out.o"
+
+-- | A set of object files which comprise a test program.
+newtype TestProgram = TestProgram { _objects :: [BS.ByteString] }
+    deriving (Semigroup)
+
+writeObjectsIn :: FilePath -> TestProgram -> IO [FilePath]
+writeObjectsIn dir (TestProgram objs) = do
+    let writeObj :: Integer -> BS.ByteString -> IO FilePath
+        writeObj i obj = do
+            let fname = "obj"++show i++".o"
+            BS.writeFile (dir </> fname) obj
+            return fname
+    sequence $ zipWith writeObj [0..] objs
+

src/Interpreter.hs

 module Interpreter
     ( Interpreter
     , refInterpreter
-    , ghcStaticInterpreter
-    , ghcDynInterpreter'
+    , ghcInterpreter
       -- * Properties of interpreters
     , agree
     , converges
@@ -23,13 +22,10 @@ type Interpreter w =
 refInterpreter :: Interpreter w
 refInterpreter = pure . interpret
 
-ghcStaticInterpreter :: Compiler -> Interpreter WordSize
-ghcStaticInterpreter comp e =
-    fromUnsigned <$> evalGhcStatic comp e
-
-ghcDynInterpreter' :: Compiler -> Interpreter WordSize
-ghcDynInterpreter' comp e =
-    fromUnsigned <$> evalGhcDyn comp e
+-- | An 'Interpreter' which compiles and evaluates the given expression.
+ghcInterpreter :: EvalMethod -> Interpreter WordSize
+ghcInterpreter em e =
+    fromUnsigned <$> evalExpr em e
 
 -- | Do two 'Interpreter's agree in their evaluation of the given expression?
 agree

src/Main.hs

@@ -5,47 +5,79 @@ module Main
     ) where
 
 import Data.Proxy
-import Data.Tagged
 import Test.QuickCheck
 import Test.Tasty
 import Test.Tasty.Options
 import Test.Tasty.QuickCheck
+import Options.Applicative
 import Prelude hiding (truncate)
 
-import Width
-import Number
-import Expr
-import ToCmm
-import Interpreter
-import CallishOp
 import CCall
-import RunGhc
+import CallishOp
+import Compiler
+import Expr
 import Expr.Parse
+import Interpreter
 import MulMayOverflow
+import Number
+import RunGhc
+import ToCmm
+import Width
+
+newtype UsedEvalMethod = UsedEvalMethod EvalMethod
+
+newtype GhcPath = GhcPath FilePath
+
+instance IsOption GhcPath where
+    defaultValue = GhcPath "ghc"
+    parseValue = pure . GhcPath
+    optionName = return "ghc-path"
+    optionHelp = return "Path to compiler"
+    optionCLParser =
+        GhcPath <$> option str (long "ghc-path" <> help "Path to compiler")
+
+newtype GhcArgs = GhcArgs [String]
+
+instance IsOption GhcArgs where
+    defaultValue = GhcArgs []
+    parseValue = pure . GhcArgs . words
+    optionName = return "ghc-args"
+    optionHelp = return "Arguments to pass to GHC"
+    optionCLParser =
+        fmap GhcArgs $ some $ option str (long "ghc-args" <> help "Arguments to pass to GHC")
+
+newtype RunItPath = RunItPath FilePath
+
+instance IsOption RunItPath where
+    defaultValue = RunItPath "run-it"
+    parseValue = pure . RunItPath
+    optionName = return "run-it-path"
+    optionHelp = return "Path to run-it executable built with tested compiler"
+    optionCLParser =
+        RunItPath <$> option str (long "run-it-path" <> help "Path to run-it")
+
+newtype Emulator = Emulator (Maybe FilePath)
+
+instance IsOption Emulator where
+    defaultValue = Emulator Nothing
+    parseValue = pure . Emulator . Just
+    optionName = return "emulator"
+    optionHelp = return "Path to emulator to use to run target executables"
+    optionCLParser =
+        Emulator . Just <$> option str (long "emulator" <> help "Path to emulator executable")
 
 basicCompiler :: FilePath -> Compiler
 basicCompiler ghcPath =
     Compiler { compPath = ghcPath
              , compArgs = ["-dcmm-lint", "-dasm-lint", "-O0"]
-             , compRunIt = "run-it"
              }
 
-compilerConfigs :: FilePath -> [(String, Compiler)]
-compilerConfigs ghcPath =
-    [ ("o0-ncg",  c0 `addArgs` ["-O0"])
-    , ("o1-ncg",  c0 `addArgs` ["-O1"])
-    , ("o0-llvm", c0 `addArgs` ["-O0", "-fllvm"])
-    , ("o1-llvm", c0 `addArgs` ["-O1", "-fllvm"])
-    ]
-  where
-    c0 = basicCompiler ghcPath
-
 -- * Properties
 
-expr_prop :: Compiler -> Expr WordSize -> Property
-expr_prop comp e = conjoin
+expr_prop :: EvalMethod -> Expr WordSize -> Property
+expr_prop em e = conjoin
     [ converges refInterpreter e
-    , agree refInterpreter (ghcDynInterpreter' comp) e
+    , agree refInterpreter (ghcInterpreter em) e
     ]
 
 quotRemProp
@@ -63,45 +95,39 @@ quotRemProp interp s a (NonZero b) = ioProperty $ do
     y = ELit b
     rhs = ((EQuot s x y) * y) + ERem s x y
 
-compilerTests :: String -> Compiler -> TestTree
-compilerTests name comp = testGroup name
-    [ testProperty "expression correctness" (expr_prop comp)
-    , prop_callish_ops_correct comp
-    , testProperty "C-Call correctness" (testCCall comp)
+compilerTests :: EvalMethod -> [TestTree]
+compilerTests em =
+    [ testProperty "expression correctness" (expr_prop em)
+    , prop_callish_ops_correct em
+    , testProperty "C-Call correctness" (testCCall em)
     , testGroup "Quot-Rem invariant"
       [ testProperty (show (knownWidth @w))
-        $ quotRemProp @w (ghcDynInterpreter' comp)
+        $ quotRemProp @w (ghcInterpreter em)
       | SomeWidth (_ :: Proxy w) <- allWidths
       ]
-    , prop_mul_may_oflo_correct comp
+    , prop_mul_may_oflo_correct em
     ]
 
-newtype RunItPath = RunItPath FilePath
-instance IsOption RunItPath where
-    defaultValue = RunItPath "run-it"
-    parseValue = Just . RunItPath
-    optionName = Tagged "run-it-path"
-    optionHelp = Tagged "Path to the run-it executable compiled with the compiler-under-test"
-
-newtype GhcPath = GhcPath FilePath
-instance IsOption GhcPath where
-    defaultValue = GhcPath "ghc"
-    parseValue = Just . GhcPath
-    optionName = Tagged "ghc-path"
-    optionHelp = Tagged "Path to compiler to test"
-
 runCompilerTests :: Compiler -> IO ()
-runCompilerTests = defaultMain . compilerTests "compiler"
+runCompilerTests =
+    defaultMain . testGroup "compiler" . compilerTests  . staticEvalMethod
 
 main :: IO ()
 main = do
     createBufferFile
-    let ing = defaultIngredients ++ [includingOptions [Option (Proxy @GhcPath), Option (Proxy @RunItPath)]]
+    let opts = [ Option (Proxy @GhcPath)
+               , Option (Proxy @GhcArgs)
+               , Option (Proxy @RunItPath)
+               , Option (Proxy @Emulator)
+               ]
+        ing = defaultIngredients ++ [includingOptions opts]
     defaultMainWithIngredients ing
         $ askOption $ \(GhcPath ghcPath) ->
+          askOption $ \(GhcArgs ghcArgs) ->
           askOption $ \(RunItPath runItPath) ->
-          testGroup "primops"
-        [ compilerTests name comp'
-        | (name, comp) <- compilerConfigs ghcPath
-        , let comp' = comp { compRunIt = runItPath }
-        ]
+          askOption $ \(Emulator mbEmulator) ->
+              let comp = Compiler ghcPath ghcArgs
+                  em = case mbEmulator of
+                         Just emulator -> emulatedStaticEvalMethod comp emulator
+                         Nothing -> DynamicEval comp runItPath
+              in testGroup "test-primops" $ compilerTests em

src/MulMayOverflow.hs

@@ -20,19 +20,19 @@ import Expr
 --  - May return zero otherwise
 --
 -- We cannot test this like other MachOps since its result is not well-defined.
-prop_mul_may_oflo_correct :: Compiler -> TestTree
-prop_mul_may_oflo_correct comp = testGroup "MulMayOflo"
-    [ testProperty (show (knownWidth @w)) (prop @w comp Proxy)
+prop_mul_may_oflo_correct :: EvalMethod -> TestTree
+prop_mul_may_oflo_correct em = testGroup "MulMayOflo"
+    [ testProperty (show (knownWidth @w)) (prop @w em Proxy)
     | SomeWidth (_ :: Proxy w) <- allWidths
     ]
 
 prop :: forall w. (KnownWidth w)
-     => Compiler
+     => EvalMethod
      -> Proxy w
      -> Expr w -> Expr w
      -> Property
-prop comp Proxy x y = ioProperty $ do
-    r <- evalMulMayOflo comp x y
+prop em Proxy x y = ioProperty $ do
+    r <- evalMulMayOflo em x y
     let does_oflo = r /= 0
     return $ counterexample (show prod) (does_overflow ==> does_oflo)
   where
@@ -42,12 +42,12 @@ prop comp Proxy x y = ioProperty $ do
 
 evalMulMayOflo
     :: forall w. (KnownWidth w)
-    => Compiler
+    => EvalMethod
     -> Expr w
     -> Expr w
     -> IO (Number WordSize)
-evalMulMayOflo comp x y =
-    fromUnsigned <$> evalCmm comp cmm
+evalMulMayOflo em x y =
+    fromUnsigned <$> evalCmm em cmm
   where
     cmm = unlines
         [ "test ( " <> cmmWordType <> " buffer ) {"

src/Number.hs

@@ -6,6 +6,7 @@ module Number
       -- * Fixed-width bit patterns
     , Number
     , numberWidth
+    , asInteger
     , toSigned
     , toUnsigned
     , fromSigned
@@ -75,6 +76,13 @@ instance Arbitrary SomeNumber where
     arbitrary =
         oneof $ forAllWidths $ \(_ :: Proxy w) -> SomeNumber @w <$> arbitrary
 
+-- | Intepret a bit pattern as either a signed or unsigned integer.
+asInteger
+    :: forall width. (KnownWidth width)
+    => Signedness -> Number width -> Integer
+asInteger Signed = toSigned
+asInteger Unsigned = fromIntegral . toUnsigned
+
 -- | Interpret a bit pattern as an unsigned number.
 toUnsigned :: Number width -> Natural
 toUnsigned (Number n) = n

src/RunGhc.hs

 -- | Utilities for running GHC and evaluating Cmm via @run-it@.
 module RunGhc
-    ( Compiler(..)
-    , addArgs
-    , evalGhcStatic
-    , evalGhcDyn
+    ( EvalMethod(..)
+    , staticEvalMethod
+    , emulatedStaticEvalMethod
+    , runTestProgram
+      -- * Evaluating expressions
+    , evalExpr
+      -- * Evaluating Cmm programs
     , evalCmm
-    , compile
-    , runIt
+      -- * Utilities
     , dumpCmmAsm
     , dumpExprAsm
     ) where
 
 import Numeric.Natural
-import System.Exit
 import System.Process
 import System.IO.Temp
 import System.FilePath
 
+import Compiler
 import Expr
 import Width
 import ToCmm
 
--- | The location of GHC and arguments to pass it.
-data Compiler = Compiler { compPath :: FilePath
-                         , compArgs :: [String]
-                         , compRunIt :: FilePath
-                           -- ^ Path of the `run-it` executable built with this compiler.
-                         }
-    deriving (Show)
-
-addArgs :: Compiler -> [String] -> Compiler
-addArgs c args = c { compArgs = compArgs c ++ args }
-
--- | Compile a set of compilation units.
-compile :: Compiler
-        -> FilePath   -- ^ working directory
-        -> [FilePath] -- ^ sources
-        -> FilePath   -- ^ output path
-        -> [String]   -- ^ other arguments
-        -> IO ()
-compile comp workDir srcs out args = do
-    runProcess' $ inTmp (proc (compPath comp) allArgs)
+data EvalMethod
+    = StaticEval { compiler :: Compiler
+                 , runExe :: FilePath -> IO String
+                 }
+    | DynamicEval { compiler :: Compiler
+                  , runItPath :: FilePath
+                  }
+
+staticEvalMethod :: Compiler -> EvalMethod
+staticEvalMethod comp =
+    StaticEval comp runExe
+  where
+    runExe exe = readProcess exe [] ""
+
+-- | An 'EvalMethod' using an emulator to run target executables.
+emulatedStaticEvalMethod :: Compiler -> FilePath -> EvalMethod
+emulatedStaticEvalMethod comp emulator =
+    StaticEval comp runExe
   where
-    allArgs = compArgs comp ++ srcs ++ args ++ ["-o", out]
-    inTmp c = c { cwd = Just workDir }
-    runProcess' p = do
-        (_, _, _, hdl) <- createProcess p
-        ExitSuccess <- waitForProcess hdl
-        return ()
-
--- | Evaluate an 'Expr' without relying on @run-it@. This is a bit slower than
--- 'evalGhcDyn'.
-evalGhcStatic
-    :: forall width. (KnownWidth width)
-    => Compiler -> Expr width -> IO Natural
-evalGhcStatic comp e = withTempDirectory "." "tmp" $ \tmpDir -> do
-    writeFile (tmpDir </> hsSrc) $ unlines
+    runExe exe = readProcess emulator [exe] ""
+
+runTestProgram :: EvalMethod -> TestProgram -> IO String
+runTestProgram (StaticEval comp runExe) = runTestProgramStatic comp runExe
+runTestProgram (DynamicEval comp runIt) = runTestProgramDyn comp runIt
+
+runTestProgramDyn :: Compiler -> FilePath -> TestProgram -> IO String
+runTestProgramDyn comp runItPath tp =
+    withTempDirectory "." "tmp" $ \tmpDir -> do
+        objs <- writeObjectsIn tmpDir tp
+        compile comp tmpDir objs soName args
+        readProcess runItPath [tmpDir </> soName] ""
+  where
+    args = ["-dynamic", "-package-env", "-", "-shared"]
+    soName = "Test.so"
+
+runTestProgramStatic :: Compiler -> (FilePath -> IO String) -> TestProgram -> IO String
+runTestProgramStatic comp runExe tp =
+    withTempDirectory "." "tmp" $ \tmpDir -> do
+        wrapper <- mkStaticWrapper comp (knownWidth @WordSize)
+        objs <- writeObjectsIn tmpDir (tp <> wrapper)
+        compile comp tmpDir objs exeName []
+        runExe (tmpDir </> exeName)
+  where
+    exeName = "Test"
+
+mkStaticWrapper
+    :: Compiler
+    -> Width
+    -> IO TestProgram
+mkStaticWrapper comp width = do
+    compileHs comp src
+  where
+    src = unlines
         [ "{-# LANGUAGE GHCForeignImportPrim #-}"
         , "{-# LANGUAGE UnliftedFFITypes #-}"
         , "{-# LANGUAGE MagicHash #-}"
@@ -64,21 +84,12 @@ evalGhcStatic comp e = withTempDirectory "." "tmp" $ \tmpDir -> do
         , "import GHC.Exts"
         , "import GHC.Ptr (Ptr(Ptr))"
         , "import System.IO.MMap"
-        , "foreign import prim \"test\" test :: Addr# -> " <> hsType w
+        , "foreign import prim \"test\" test :: Addr# -> " <> hsType width
         , "main :: IO ()"
         , "main = do"
         , "  (Ptr p, _, _, _) <- mmapFilePtr \"test\" ReadOnly Nothing"
-        , "  print $ " <> toHsWord w "test p"
+        , "  print $ " <> toHsWord width "test p"
         ]
-    writeFile (tmpDir </> cmmSrc) $ toCmmDecl "test" e
-    compile comp tmpDir [cmmSrc, hsSrc] exeName []
-    out <- readProcess (tmpDir </> exeName) [] ""
-    return $ read out
-  where
-    w = knownWidth @width
-    exeName = "Test"
-    cmmSrc = "test-cmm.cmm"
-    hsSrc = "test-hs.hs"
 
 hsType :: Width -> String
 hsType W8  = "Word8#"
@@ -93,30 +104,18 @@ toHsWord w x = "W# " <> parens (extendFn <> " " <> parens x)
       | w == W64  = ""
       | otherwise =  "extendWord" <> show (widthBits w) <> "#"
 
+evalCmm :: EvalMethod -> Cmm -> IO Natural
+evalCmm em cmm = do
+    tp <- compileCmm (compiler em) cmm
+    out <- runTestProgram em tp
+    return $ read out
+
 -- | Evaluate an 'Expr'.
-evalGhcDyn :: Compiler -> Expr WordSize -> IO Natural
-evalGhcDyn comp e = evalCmm comp $ toCmmDecl "test" e
+evalExpr :: EvalMethod -> Expr WordSize -> IO Natural
+evalExpr em = evalCmm em . toCmmDecl "test"
 
 type Cmm = String
 
--- | Invoke @run-it@ on the given shared object.
-runIt :: Compiler -> FilePath -> IO String
-runIt comp soName =
-    readProcess (compRunIt comp) [soName] ""
-
--- | Evaluate a Cmm function using @run-it@. The function must be named @test@
--- and must return a @bits64@.
-evalCmm :: Compiler -> Cmm -> IO Natural
-evalCmm comp cmm = withTempDirectory "." "tmp" $ \tmpDir -> do
-    writeFile (tmpDir </> cmmSrc) cmm
-    let args = ["-dynamic", "-package-env", "-", "-shared"]
-    compile comp tmpDir [cmmSrc] soName args
-    out <- runIt comp (tmpDir </> soName)
-    return $ read out
-  where
-    soName = "Test.so"
-    cmmSrc = "test-cmm.cmm"
-
 -- | Compile the given Cmm procedure and dump its disassembly.
 dumpCmmAsm :: Compiler -> Cmm -> IO String
 dumpCmmAsm comp cmm = withTempDirectory "." "tmp" $ \tmpDir -> do

test-primops.cabal

@@ -15,6 +15,7 @@ executable test-primops
                       Number,
                       Expr,
                       Expr.Parse,
+                      Compiler,
                       Interpreter,
                       ToCmm,
                       CallishOp,
@@ -28,6 +29,7 @@ executable test-primops
                       directory,
                       filepath,
                       megaparsec,
+                      optparse-applicative,
                       parser-combinators,
                       process,
                       tagged,