inline-asm 0.1.0.0 → 0.1.1.0
raw patch · 6 files changed
+81/−19 lines, 6 filesdep +QuickCheckdep +hspec
Dependencies added: QuickCheck, hspec
Files
- ChangeLog.md +7/−1
- README.md +6/−0
- app/Main.hs +3/−3
- inline-asm.cabal +5/−3
- src/Language/Asm/Inline.hs +42/−11
- test/Spec.hs +18/−1
ChangeLog.md view
@@ -1,3 +1,9 @@ # Changelog for inline-asm -## Unreleased changes+## v0.1.1.0++* Support returning tuples.++## v0.1.0.0++* Initial implementation.
README.md view
@@ -4,3 +4,9 @@ Did you try `inline-c`, but it's not enough? You need more? Nothing seems to satisfy? `inline-asm` to the rescue!++For now the usage is pretty straightforward: use `defineAsmFun` to define the+corresponding function, like+```haskell+defineAsmFun "timesTwo" [t| Word -> Word |] "add %rbx, %rbx"+````
app/Main.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes #-}+{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, UnboxedTuples #-} module Main where import Language.Asm.Inline -defineAsmFun "foobar" [t| Word -> Word |] "add %rbx, %rbx"+defineAsmFun "swap" [t| Int -> Int -> (Int, Int) |] "xchg %rbx, %r14" main :: IO ()-main = print $ foobar 21+main = print $ swap 2 3
inline-asm.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: e27b467c99b6f79a5aa43f7fbfa55f44eca8495e93b7a08b9c9ce2a09d17cbd0+-- hash: 5d6508f3403863db4c5f4cd69ef0b0124b65babf9779d5a647700388d14ddb48 name: inline-asm-version: 0.1.0.0+version: 0.1.1.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@@ -66,8 +66,10 @@ test ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends:- base >=4.7 && <5+ QuickCheck+ , base >=4.7 && <5 , ghc-prim+ , hspec , inline-asm , template-haskell >=2.15.0.0 , uniplate
src/Language/Asm/Inline.hs view
@@ -3,7 +3,9 @@ {-# LANGUAGE DataKinds, PolyKinds, TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} -module Language.Asm.Inline where+module Language.Asm.Inline+( defineAsmFun+) where import Control.Monad import Data.Generics.Uniplate.Data@@ -12,9 +14,9 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax -class AsmArg a (rep :: RuntimeRep) (uty :: TYPE rep) | a -> rep, a -> uty where- unbox :: a -> uty- rebox :: uty -> a+class AsmArg a (rep :: RuntimeRep) (unboxedTy :: TYPE rep) | a -> rep, a -> unboxedTy where+ unbox :: a -> unboxedTy+ rebox :: unboxedTy -> a instance AsmArg Int 'IntRep Int# where unbox (I# w) = w@@ -24,6 +26,15 @@ unbox (W# w) = w rebox = W# +{- TODO better to do reboxing via this instance if it's possible to make this work+ - contrarily to the ghc's complaints about illegal levity polymorphism.++instance (AsmArg a repa unboxedTyA, AsmArg b repb unboxedTyB)+ => AsmArg (a, b) ('TupleRep '[ repa, repb ]) (# unboxedTyA, unboxedTyB #) where+ unbox (a, b) = (# unbox a, unbox b #)+ rebox (# a# , b# #) = ( rebox a# , rebox b# )+ -}+ defineAsmFun :: String -> Q Type -> String -> Q [Dec] defineAsmFun name funTyQ asmCode = do addForeignSource LangAsm $ unlines [ ".global " <> asmName@@ -36,27 +47,47 @@ wrapperFunD <- mkFunD name importedName funTy pure [ ForeignD $ ImportF Prim Safe asmName importedName $ unliftType funTy- , SigD (mkName name) funTy+ , SigD name' funTy , wrapperFunD+ , PragmaD $ InlineP name' Inline ConLike AllPhases ] where+ name' = mkName name asmName = name <> "_unlifted" mkFunD :: String -> Name -> Type -> Q Dec mkFunD funName importedName funTy = do argNames <- replicateM (countArgs funTy) $ newName "arg" funAppE <- foldM f (VarE importedName) argNames- body <- [e| rebox $(pure funAppE) |]+ body <- case detectRetTuple funTy of+ Nothing -> [e| rebox $(pure funAppE) |]+ Just n -> do+ retNames <- replicateM n $ newName "ret"+ boxing <- forM retNames $ \name -> [e| rebox $(pure $ VarE name) |]+ [e| case $(pure funAppE) of+ $(pure $ UnboxedTupP $ VarP <$> retNames) -> $(pure $ TupE $ boxing)+ |] pure $ FunD (mkName funName) [Clause (VarP <$> argNames) (NormalB body) []] where f acc argName = [e| $(pure acc) (unbox $(pure $ VarE argName)) |] unliftType :: Type -> Type-unliftType = transformBi f+unliftType = transformBi unliftTuple . transformBi unliftBaseTy where- f x | x == ''Word = ''Word#- | x == ''Int = ''Int#- | otherwise = x+ unliftBaseTy x | x == ''Word = ''Word#+ | x == ''Int = ''Int#+ | otherwise = x+ unliftTuple (TupleT n) = UnboxedTupleT n+ unliftTuple x = x countArgs :: Type -> Int-countArgs ty = length [ () | ConT _ <- universeBi ty ] - 1+countArgs ty = length $ filter (== ArrowT) $ universeBi ty++-- This doesn't check if this is indeed a return type,+-- but since we are not going to support argument tuples (and we'll add a check about that later),+-- it should be fine.+detectRetTuple :: Type -> Maybe Int+detectRetTuple ty | [TupleT n] <- tuples = Just n+ | otherwise = Nothing+ where+ tuples = [ t | t@(TupleT _) <- universeBi ty]
test/Spec.hs view
@@ -1,2 +1,19 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, UnboxedTuples #-}++import Test.Hspec+import Test.QuickCheck++import Language.Asm.Inline++defineAsmFun "timesTwo" [t| Int -> Int |] "add %rbx, %rbx"+defineAsmFun "plusWord" [t| Int -> Int -> Int |] "add %r14, %rbx"+defineAsmFun "swap" [t| Int -> Int -> (Int, Int) |] "xchg %rbx, %r14"+ main :: IO ()-main = putStrLn "Test suite not yet implemented"+main = hspec $ do+ describe "Basic functions" $ do+ it "timesTwo" $ property $ \num -> timesTwo num `shouldBe` num * 2+ it "plusWord" $ property $ \n1 n2 -> plusWord n1 n2 `shouldBe` n1 + n2+ describe "Returning tuples" $+ it "swap" $ property $ \n1 n2 -> swap n1 n2 `shouldBe` (n2, n1)