diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ # Changelog for inline-asm -## Unreleased changes +## v0.1.1.0 + +* Support returning tuples. + +## v0.1.0.0 + +* Initial implementation. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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" +```` diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/inline-asm.cabal b/inline-asm.cabal --- a/inline-asm.cabal +++ b/inline-asm.cabal @@ -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 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 diff --git a/src/Language/Asm/Inline.hs b/src/Language/Asm/Inline.hs --- a/src/Language/Asm/Inline.hs +++ b/src/Language/Asm/Inline.hs @@ -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] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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)