inline-asm 0.4.0.2 → 0.5.0.0
raw patch · 9 files changed
+418/−86 lines, 9 filesdep +Chartdep +Chart-cairodep +interpolatedep ~template-haskellnew-component:exe:ex-rdtsc
Dependencies added: Chart, Chart-cairo, interpolate, lens, primitive
Dependency ranges changed: template-haskell
Files
- ChangeLog.md +6/−0
- README.md +90/−10
- app/Main.hs +0/−34
- examples/Rdtsc.hs +127/−0
- examples/cbits/rdtsc.c +10/−0
- inline-asm.cabal +29/−11
- src/Language/Asm/Inline.hs +124/−22
- src/Language/Asm/Inline/QQ.hs +11/−9
- test/Spec.hs +21/−0
ChangeLog.md view
@@ -1,5 +1,11 @@ # Changelog for inline-asm +## v0.5.0.0++* Add `defineAsmFunM` for impure assembly functions (think `rdtsc`) that shall live in a `PrimMonad`.+* Drop support for template-haskell-2.15.0.0.+* Introduce (optionally buildable) examples instead of some ad-hoc `app/Main.hs`.+ ## v0.4.0.2 * Fix compatibility with the recently released template-haskell-2.16.0.0.
README.md view
@@ -21,7 +21,8 @@ add $2, {b} |] ```-(note the `{a}`, `{b}` antiquoters)+This provides a function `swap2p1 :: Int -> Int -> (Int, Int)` that, well, swaps two `Int`s.+Note that the resulting function is pure, and the `{a}`, `{b}` antiquoters. Getting the last character of a `ByteString`, or a default character if it's empty: ```haskell@@ -36,7 +37,8 @@ mov {def}, {w} |] ```-(note the special `{bs:ptr}` and `{bs:len}` antiquoters, as well as `RET_HASK` command to return early)+This provides a function `lastChar :: ByteString -> Word -> Word`.+Note the special `{bs:ptr}` and `{bs:len}` antiquoters, as well as `RET_HASK` command to return early. SIMD-accelerated character occurrences count in a string: ```haskell@@ -77,9 +79,24 @@ jnz loop|] <> unroll "i" [15,14..12] [asm| pop %r{i} |] ```-(note the `unroll`/`unrolls` Haskell function for compile-time code generation and loop unrolling-with arithmetic expressions in the templates)+This provides a function `countCharSSE42 :: Word8 -> Ptr Word8 -> Int -> Int`.+Note the `unroll`/`unrolls` Haskell function for compile-time code generation and loop unrolling+with arithmetic expressions in the templates. +Impure computation depending on some external state, like reading the CPU's time stamp counter:+```haskell+defineAsmFunM "rdtsc"+ [asmTy| | (out : Word64) |]+ [asm|+ rdtsc+ mov %rdx, {out}+ shl $32, {out}+ add %rax, {out}+ |]+```+This provides a function `rdtsc :: PrimMonad m => m Word64` which can be used in `ST` or `IO` contexts.+Note the **M** letter in `defineAsmFunM`.+ ## Basic usage The entry point is the `defineAsmFun` function from `Language.Asm.Inline`@@ -120,7 +137,7 @@ This will both update the mapping from argument names to register names as well as issue an assembly `mov` command. -In case you need to return early to Haskell-land, just write `RET_HASK`,+In case you need to return early to the Haskell-land, just write `RET_HASK`, which gets substituted by the actual command to return to Haskell. ### Explicit loop unrolling@@ -154,15 +171,78 @@ The `countCharSSE42` function above might be a pretty good example. +### Impure functions +Most of the functions above are actually pure:+they return the same result given the same parameters and have no side effects.+Perhaps unsurprisingly, this is not always the case.+Let's consider the `rdtsc` example again and assume we've written+```haskell+defineAsmFun "rdtsc"+ [asmTy| (_ : Unit) | (out : Word64) |]+ [asm|+ rdtsc+ mov %rdx, {out}+ shl $32, {out}+ add %rax, {out}+ |]+```+(BTW we need a dummy `Unit` input here+since otherwise the type of the generated imported Assembly function would be just `Word64#`,+which is not a function but a value, and thus disallowed by GHC).++How do we use this function to measure something?+We'd probably write something like+```haskell+measure = do+ let r1 = rdtsc Unit+ runLongComputation+ let r2 = rdtsc Unit+ print $ r2 - r1+```+The problem is that the compiler is very keen on transforming this into+```haskell+measure = do+ let r1 = rdtsc Unit+ runLongComputation+ let r2 = r1+ print $ r2 - r1+```+so every computation is executed instantly according to our measurements,+and no amount of `{-# NOINLINE #-}` and the likes will fix it.++The only fix is to actually thread through the `State#` token,+which is what happens when we use the monadic function `defineAsmFunM`:+```haskell+defineAsmFunM "rdtsc"+ [asmTy| | (out : Word64) |]+ [asm|+ rdtsc+ mov %rdx, {out}+ shl $32, {out}+ add %rax, {out}+ |]+```+In this case, the generated Assembly function would be imported with the type+`forall s. State# s -> (# State# s, Word64# #)`,+and what happens to `State# s` is completely opaque to the compiler, so it can no longer "optimize" this,+and the following works as expected:+```haskell+measure = do+ r1 <- rdtsc+ runLongComputation+ r2 <- rdtsc+ print $ r2 - r1+```++By the way, now that there's the state token parameter, we no longer need a dummy `Unit`.+ ## Safety and notes * Firstly, all of this is utterly unsafe.-* The compiler sees the generated functions as pure, so if a function calls,- say, `RDRAND` and is itself called more than once to get several random numbers,- care must be taken to ensure the compiler doesn't elide extra calls.- We might introduce some shortcuts to allow wrapping such impure functions- in an `IO` or `PrimMonad` or soemthing similar.+* While this package provides some shortcuts,+ understanding the calling convention (in particular, which registers are actually used) is important.+ The best source of truth is, of course, GHC's [source code](https://github.com/ghc/ghc/blob/HEAD/rts/include/stg/MachRegs.h). * Each function is compiled in its own `.S` file, so one can freely pick arbitrary naming for the labels and so on, but, on the other hand, one cannot access labels in other functions.
− app/Main.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}-{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, UnboxedTuples #-}--module Main where--import Language.Asm.Inline-import Language.Asm.Inline.QQ--defineAsmFun "swap" [t| Int -> Int -> (Int, Int) |] "xchg %rbx, %r14"--defineAsmFun "swap2p1"- [asmTy| (a : Int) (b : Int) | (a : Int) (b : Int) |]- [asm|- xchg {a}, {b}- add $1, {b}- |]--{--defineAsmFun "swap2p1"- [t| Int -> Int -> (Int, Int) |]- [asm| a b |- xchg {a}, {b}- add $1, {b}- |]--defineAsmFun "testInt" [t| Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int |] "int $3"-defineAsmFun "testDouble" [t| Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double |] "int $3"--}--main :: IO ()-main = do- print $ swap2p1 2 4- --print $ testInt 0 1 2 3 4 5 6- --print $ testDouble 1 1 0 0 0 0 1
+ examples/Rdtsc.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, UnboxedTuples #-}+{-# LANGUAGE LambdaCase, BlockArguments, NumericUnderscores #-}++module Main where++import Control.Monad+import Data.List+import Data.String.Interpolate+import Graphics.Rendering.Chart.Easy+import Graphics.Rendering.Chart.Backend.Cairo+import GHC.Word+import System.Environment++import Language.Asm.Inline+import Language.Asm.Inline.QQ++defineAsmFunM "rdtsc"+ [asmTy| | (out : Word64) |]+ [asm|+ lfence+ rdtsc+ mov %rdx, {out}+ shl $32, {out}+ add %rax, {out}+ lfence+ |]++defineAsmFunM "rdtscP"+ [asmTy| | (hi : Word32) (lo : Word32) |]+ [asm|+ rdtsc+ mov %rdx, {hi}+ mov %rax, {lo}+ |]++defineAsmFunM "rdtsc2"+ [asmTy| | (out1 : Word64) (out2 : Word64) |]+ [asm|+ lfence+ rdtsc+ mov %rdx, {out1}+ shl $32, {out1}+ add %rax, {out1}+ lfence++ lfence+ rdtsc+ mov %rdx, {out2}+ shl $32, {out2}+ add %rax, {out2}+ lfence+ |]++example :: IO ()+example = do+ v1 <- rdtsc+ v2 <- rdtsc+ print v1+ print v2+ print $ v2 - v1++ p1 <- rdtscP+ p2 <- rdtscP+ print p1+ print p2++ (o1, o2) <- rdtsc2+ print $ o2 - o1++main :: IO ()+main = getArgs >>= \case [] -> example+ ["bench"] -> bench+ _ -> putStrLn "Unknown args"++---- Benchmarking stuff+bench :: IO ()+bench = do+ baselineMeas <- removeOutliers <$> replicateM count do+ (v1, v2) <- rdtsc2+ pure $ v2 - v1+ asmMeas <- removeOutliers <$> replicateM count do+ v1 <- rdtsc+ v2 <- rdtsc+ pure $ v2 - v1+ cMeas <- removeOutliers <$> replicateM count do+ v1 <- rdtscC+ v2 <- rdtscC+ pure $ v2 - v1++ printPlot [("only asm", baselineMeas), ("inline-asm", asmMeas), ("c", cMeas)]+ where+ count = 1_000_000 :: Int++foreign import ccall unsafe "rdtscC"+ rdtscC :: IO Word64++printPlot :: [(String, [Word64])] -> IO ()+printPlot allStats = do+ forM_ allStats $ uncurry printStats+ toFile def "out.svg" $ do+ layout_title .= "rdtsc diff time"+ mapM_ (plot . uncurry histPlot) allStats+ where+ minVal = fromIntegral $ minimum $ concat $ snd <$> allStats+ maxVal = fromIntegral $ maximum $ concat $ snd <$> allStats+ histPlot :: String -> [Word64] -> EC l (Plot Double Int)+ histPlot name vals = do+ color <- takeColor+ pure $ histToPlot $ plot_hist_title .~ name+ $ plot_hist_values .~ (fromIntegral <$> vals)+ $ plot_hist_fill_style.fill_color .~ dissolve 0.2 color+ $ plot_hist_line_style.line_color .~ color+ $ plot_hist_range ?~ (minVal, maxVal)+ $ defaultPlotHist++printStats :: String -> [Word64] -> IO ()+printStats name allRuns = putStrLn [i|#{name}:\n min: #{minimum runs}; max: #{maximum runs}; avg: #{avg}|]+ where+ runs = removeOutliers allRuns+ avg = sum runs `div` genericLength runs++removeOutliers :: [Word64] -> [Word64]+removeOutliers allRuns = drop cutoff $ take (runsLen - cutoff) $ sort allRuns+ where+ runsLen = genericLength allRuns+ cutoff = runsLen `div` 10000
+ examples/cbits/rdtsc.c view
@@ -0,0 +1,10 @@+#include <x86intrin.h>++unsigned long long rdtscC()+{+ _mm_lfence();+ unsigned long long res = __rdtsc();+ _mm_lfence();+ return res;+}+
inline-asm.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: fd06f801cd1e8354d11a3ed0cb6623ada695ee43df28ddfa368a6a3f8dc76136+-- hash: c88df95b319282f818dabe35ff5bf3c7d2c92cfefebc2957b6e522e25338e44d name: inline-asm-version: 0.4.0.2+version: 0.5.0.0 synopsis: Inline some Assembly in ur Haskell! description: Please see the README on GitHub at <https://github.com/0xd34df00d/inline-asm#readme> category: FFI@@ -27,6 +27,11 @@ type: git location: https://github.com/0xd34df00d/inline-asm +flag with-examples+ description: Build examples+ manual: False+ default: False+ library exposed-modules: Language.Asm.Inline@@ -47,29 +52,41 @@ , megaparsec , mtl , parser-combinators- , template-haskell >=2.15.0.0+ , primitive+ , template-haskell >=2.16.0.0 , uniplate default-language: Haskell2010 -executable inline-asm-exe- main-is: Main.hs+executable ex-rdtsc+ main-is: Rdtsc.hs other-modules: Paths_inline_asm hs-source-dirs:- app- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ examples+ ghc-options: -Wall -threaded -rtsopts+ c-sources:+ examples/cbits/rdtsc.c build-depends:- base >=4.7 && <5+ Chart+ , Chart-cairo+ , base >=4.7 && <5 , bytestring , containers , either , ghc-prim , inline-asm+ , interpolate+ , lens , megaparsec , mtl , parser-combinators- , template-haskell >=2.15.0.0+ , primitive+ , template-haskell >=2.16.0.0 , uniplate+ if flag(with-examples)+ buildable: True+ else+ buildable: False default-language: Haskell2010 test-suite inline-asm-test@@ -93,6 +110,7 @@ , megaparsec , mtl , parser-combinators- , template-haskell >=2.15.0.0+ , primitive+ , template-haskell >=2.16.0.0 , uniplate default-language: Haskell2010
src/Language/Asm/Inline.hs view
@@ -1,16 +1,24 @@-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MagicHash, UnboxedTuples #-} {-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances, FunctionalDependencies #-} {-# LANGUAGE DataKinds, PolyKinds, TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} -module Language.Asm.Inline(defineAsmFun) where+#include "MachDeps.h" +module Language.Asm.Inline+( defineAsmFun+, defineAsmFunM+, Unit(..)+) where+ import qualified Data.ByteString as BS import Control.Monad+import Control.Monad.Primitive import Data.Generics.Uniplate.Data import Data.List import Foreign.Ptr+import GHC.Int import GHC.Prim import GHC.Ptr import GHC.Types hiding (Type)@@ -26,10 +34,36 @@ unbox :: a -> unboxedTy rebox :: unboxedTy -> a +data Unit = Unit++instance AsmArg Unit 'IntRep Int# where+ unbox _ = 0#+ rebox _ = Unit+ instance AsmArg Int 'IntRep Int# where unbox (I# w) = w rebox = I# +instance AsmArg Int8 'IntRep Int# where+ unbox (I8# w) = w+ rebox = I8#++instance AsmArg Int16 'IntRep Int# where+ unbox (I16# w) = w+ rebox = I16#++instance AsmArg Int32 'IntRep Int# where+ unbox (I32# w) = w+ rebox = I32#++#if WORD_SIZE_IN_BITS > 32+instance AsmArg Int64 'IntRep Int# where+#else+instance AsmArg Int64 'Int64Rep Int64# where+#endif+ unbox (I64# w) = w+ rebox = I64#+ instance AsmArg Word 'WordRep Word# where unbox (W# w) = w rebox = W#@@ -38,6 +72,22 @@ unbox (W8# w) = w rebox = W8# +instance AsmArg Word16 'WordRep Word# where+ unbox (W16# w) = w+ rebox = W16#++instance AsmArg Word32 'WordRep Word# where+ unbox (W32# w) = w+ rebox = W32#++#if WORD_SIZE_IN_BITS > 32+instance AsmArg Word64 'WordRep Word# where+#else+instance AsmArg Word64 'Word64Rep Word64# where+#endif+ unbox (W64# w) = w+ rebox = W64#+ instance AsmArg Double 'DoubleRep Double# where unbox (D# d) = d rebox = D#@@ -57,44 +107,95 @@ go str@(s:ss) | what `isPrefixOf` str = with <> go (drop (length what) str) | otherwise = s : go ss -defineAsmFun :: AsmCode tyAnn code => String -> tyAnn -> code -> Q [Dec]-defineAsmFun name tyAnn asmCode = do+data FunKind = Pure | Monadic++defineAsmFunImpl :: AsmCode tyAnn code => FunKind -> String -> tyAnn -> code -> Q [Dec]+defineAsmFunImpl kind name tyAnn asmCode = do addForeignSource LangAsm $ unlines [ ".global " <> asmName , asmName <> ":" , replace "RET_HASK" retToHask $ codeToString tyAnn asmCode , retToHask ] funTy <- toTypeQ tyAnn+ (importedTy, sigTy) <- case kind of+ Pure -> pure (funTy, funTy)+ Monadic -> (,) <$> stateifyUnlifted funTy <*> stateifyLifted funTy let importedName = mkName asmName- wrapperFunD <- mkFunD name importedName funTy+ wrapperFunD <- mkFunD kind name importedName funTy pure- [ ForeignD $ ImportF Prim Safe asmName importedName $ unliftType funTy- , SigD name' funTy+ [ ForeignD $ ImportF Prim Safe asmName importedName $ unliftType importedTy+ , SigD name' sigTy , wrapperFunD- , PragmaD $ InlineP name' Inline ConLike AllPhases+ , PragmaD $ InlineP name' Inline FunLike AllPhases ] where name' = mkName name asmName = name <> "_unlifted" retToHask = "jmp *(%rbp)" -mkFunD :: String -> Name -> Type -> Q Dec-mkFunD funName importedName funTy = do+defineAsmFun :: AsmCode tyAnn code => String -> tyAnn -> code -> Q [Dec]+defineAsmFun = defineAsmFunImpl Pure++defineAsmFunM :: AsmCode tyAnn code => String -> tyAnn -> code -> Q [Dec]+defineAsmFunM = defineAsmFunImpl Monadic++-- |Converts the wrapped function type to live in a 'PrimMonad':+-- given 'Ty1 -> Ty2 -> Ret' it produces+-- 'forall m. PrimMonad m => Ty1 -> Ty2 -> m Ret'.+stateifyLifted :: Type -> Q Type+stateifyLifted ty = do+ m <- newName "m"+ ForallT [PlainTV m] [AppT (ConT ''PrimMonad) (VarT m)] <$> go m ty+ where+ go m (AppT (AppT ArrowT lhs) rhs) = AppT (AppT ArrowT lhs) <$> go m rhs+ go m rhs = [t| $(pure $ VarT m) $(pure rhs) |]++-- |Converts the unwrapped/unlifted function type to be a 'primitive' action:+-- given 'Ty1# -> Ty2# -> Ret#' it produces+-- 'forall s. Ty1# -> Ty2# -> State# s -> (# State# s, Ret# #)'.+stateifyUnlifted :: Type -> Q Type+stateifyUnlifted ty = do+ s <- newName "s"+ ForallT [PlainTV s] [] <$> go s ty+ where+ go s (AppT (AppT ArrowT lhs) rhs) = AppT (AppT ArrowT lhs) <$> go s rhs+ go s rhs = [t| State# $(pure $ VarT s) -> (# State# $(pure $ VarT s), $(pure rhs) #) |]++mkFunD :: FunKind -> String -> Name -> Type -> Q Dec+mkFunD kind funName importedName funTy = do+ token <- newName "token" argNames <- replicateM (countArgs funTy) $ newName "arg" funAppE <- foldM f (VarE importedName) $ zip (VarE <$> argNames) (getArgs funTy)+ fullFunAppE <- case kind of+ Pure -> pure funAppE+ Monadic -> [e| $(pure funAppE) $(pure $ VarE token) |]+ body <- case detectRetTuple funTy of- Nothing -> [e| rebox $(pure funAppE) |]+ Nothing ->+ case kind of+ Pure ->+ [e| rebox $(pure fullFunAppE) |]+ Monadic ->+ [e| case $(pure fullFunAppE) of+ (# token', res #) -> (# token', rebox res #)+ |] Just n -> do retNames <- replicateM n $ newName "ret"-#if MIN_VERSION_template_haskell(2, 16, 0) boxing <- forM retNames $ \name -> Just <$> [e| rebox $(pure $ VarE name) |]-#else- boxing <- forM retNames $ \name -> [e| rebox $(pure $ VarE name) |]-#endif- [e| case $(pure funAppE) of- $(pure $ UnboxedTupP $ VarP <$> retNames) -> $(pure $ TupE boxing)- |]- pure $ FunD (mkName funName) [Clause (VarP <$> argNames) (NormalB body) []]+ case kind of+ Pure ->+ [e| case $(pure fullFunAppE) of+ $(pure $ UnboxedTupP $ VarP <$> retNames) -> $(pure $ TupE boxing)+ |]+ Monadic ->+ [e| case $(pure fullFunAppE) of+ (# token', $(pure $ UnboxedTupP $ VarP <$> retNames) #) -> (# token', $(pure $ TupE boxing) #)+ |]++ body' <- case kind of+ Pure -> pure body+ Monadic -> [e| primitive (\ $(pure $ VarP token) -> $(pure body)) |]+ pure $ FunD (mkName funName) [Clause (VarP <$> argNames) (NormalB body') []] where f acc (argName, argType) | argType == ConT ''BS.ByteString = [e| $(pure acc) (unbox $ getBSAddr $(pure argName))@@ -102,17 +203,18 @@ |] | otherwise = [e| $(pure acc) (unbox $(pure argName)) |] +{-# NOINLINE unliftType #-} unliftType :: Type -> Type unliftType = transformBi unliftTuple . transformBi unliftBaseTy . transformBi unliftPtrs . transformBi unliftBS where- unliftBaseTy x | x == ''Word = ''Word#- | x == ''Word8 = ''Word#- | x == ''Int = ''Int#+ unliftBaseTy x | x `elem` [ ''Word, ''Word8, ''Word16, ''Word32, ''Word64 ] = ''Word#+ | x `elem` [ ''Int, ''Int8, ''Int16, ''Int32, ''Int64 ] = ''Int# | x == ''Double = ''Double# | x == ''Float = ''Float#+ | x == ''Unit = ''Int# | otherwise = x unliftPtrs (AppT (ConT name) _) | name == ''Ptr = ConT ''Addr#
src/Language/Asm/Inline/QQ.hs view
@@ -137,14 +137,15 @@ data VarTyCat = Integer | Other deriving (Eq, Ord, Show, Enum, Bounded) categorize :: AsmVarName -> AsmVarType -> Either String [(AsmVarName, VarTyCat)]-categorize name (AsmVarType "Int") = pure [(name, Integer)]-categorize name (AsmVarType "Word") = pure [(name, Integer)]-categorize name (AsmVarType "Word8") = pure [(name, Integer)]-categorize name (AsmVarType "Ptr") = pure [(name, Integer)]-categorize name (AsmVarType "Float") = pure [(name, Other)]-categorize name (AsmVarType "Double") = pure [(name, Other)]+categorize name (AsmVarType ty)+ | ty `elem` (integralFamily "Int"+ <> integralFamily "Word"+ <> ["Ptr", "Unit"]) = pure [(name, Integer)]+ | ty `elem` ["Float", "Double"] = pure [(name, Other)]+ where+ integralFamily base = [base, base <> "8", base <> "16", base <> "32", base <> "64"] categorize name (AsmVarType "ByteString") = pure [(name <> ":ptr", Integer), (name <> ":len", Integer)]-categorize _ (AsmVarType s) = throwError $ "Unknown register type: " <> s+categorize _ (AsmVarType s) = throwError $ "Unknown register type for variable type `" <> s <> "`" argIdxToReg :: VarTyCat -> Int -> Either String RegName argIdxToReg Integer 0 = pure "rbx"@@ -234,8 +235,9 @@ maybeRetTyNames <- lookupTyNames rets case maybeRetTyNames of Left err -> error err- Right [tyName] -> if | tyName == ''Ptr -> [t| Ptr () |]- | otherwise -> pure $ ConT tyName+ Right [tyName] -> if tyName == ''Ptr+ then [t| Ptr () |]+ else pure $ ConT tyName Right retNames -> pure $ foldl retFolder (TupleT $ length retNames) retNames where retFolder tupAcc ret | ret == ''Ptr = tupAcc `AppT` (ConT ret `AppT` TupleT 0)
test/Spec.hs view
@@ -19,7 +19,21 @@ defineAsmFun "plusInt" [t| Int -> Int -> Int |] "add %r14, %rbx" defineAsmFun "swapInts" [t| Int -> Int -> (Int, Int) |] "xchg %rbx, %r14" +defineAsmFun "noInputs"+ [asmTy| (_ : Unit) | (out : Int) |]+ [asm|+ mov $42, {out}+ |] +defineAsmFunM "rdtsc"+ [asmTy| | (out : Word64) |]+ [asm|+ rdtsc+ mov %rdx, {out}+ shl $32, {out}+ add %rax, {out}+ |]+ defineAsmFun "timesTwoIntQQ" [asmTy| (a : Int) | (_ : Int) |] [asm| add {a}, {a} |]@@ -152,6 +166,13 @@ main :: IO () main = hspec $ modifyMaxSuccess (const 1000) $ do+ describe "Works on units" $ do+ it "no inputs is ok" $ noInputs Unit `shouldBe` 42+ describe "Works on rdtsc" $ do+ it "is increasing" $ property $ \() -> do+ v1 <- rdtsc+ v2 <- rdtsc+ (v1, v2) `shouldSatisfy` uncurry (<) describe "Works with Ints (the non-QQ version)" $ do it "timesTwo" $ property $ \num -> timesTwoInt num `shouldBe` num * 2 it "plusInt" $ property $ \n1 n2 -> plusInt n1 n2 `shouldBe` n1 + n2