inline-asm 0.1.1.0 → 0.2.0.0
raw patch · 9 files changed
+167/−22 lines, 9 filesdep +eitherdep +mtl
Dependencies added: either, mtl
Files
- ChangeLog.md +4/−0
- README.md +19/−0
- app/Main.hs +15/−2
- inline-asm.cabal +11/−2
- src/Language/Asm/Inline.hs +19/−17
- src/Language/Asm/Inline/AsmCode.hs +13/−0
- src/Language/Asm/Inline/QQ.hs +78/−0
- src/Language/Asm/Inline/Util.hs +7/−0
- test/Spec.hs +1/−1
ChangeLog.md view
@@ -1,5 +1,9 @@ # Changelog for inline-asm +## v0.2.0.0++* Support named arguments.+ ## v0.1.1.0 * Support returning tuples.
README.md view
@@ -1,5 +1,7 @@ # inline-asm +[![Build Status][travis-badge]][travis]+ _When inline C is too safe_. Did you try `inline-c`, but it's not enough? You need more? Nothing seems to satisfy?@@ -10,3 +12,20 @@ ```haskell defineAsmFun "timesTwo" [t| Word -> Word |] "add %rbx, %rbx" ````+and then use the function `timesTwo` as any other function of type `Word -> Word`:+```haskell+main = print $ timesTwo 21+```++There is also an alternative notation allowing named arguments:+```haskell+defineAsmFun "swap2p1"+ [t| Int -> Int -> (Int, Int) |]+ [asm| a b |+ xchg ${a}, ${b}+ add $1, ${b}+ |]+```++[travis]: <https://travis-ci.org/0xd34df00d/inline-asm>+[travis-badge]: <https://travis-ci.org/0xd34df00d/inline-asm.svg?branch=master>
app/Main.hs view
@@ -1,11 +1,24 @@-{-# LANGUAGE TemplateHaskell #-}+{-# 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"+ [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 = print $ swap 2 3+main = do+ print $ testInt 0 1 2 3 4 5 6+ print $ testDouble 1 1 0 0 0 0 1
inline-asm.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 5d6508f3403863db4c5f4cd69ef0b0124b65babf9779d5a647700388d14ddb48+-- hash: b58246a639e949912f040d75472b9a114b43d99ceb097b6ff9df53c0c370b8d4 name: inline-asm-version: 0.1.1.0+version: 0.2.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@@ -30,6 +30,9 @@ library exposed-modules: Language.Asm.Inline+ Language.Asm.Inline.AsmCode+ Language.Asm.Inline.QQ+ Language.Asm.Inline.Util other-modules: Paths_inline_asm hs-source-dirs:@@ -37,7 +40,9 @@ ghc-options: -Wall build-depends: base >=4.7 && <5+ , either , ghc-prim+ , mtl , template-haskell >=2.15.0.0 , uniplate default-language: Haskell2010@@ -51,8 +56,10 @@ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5+ , either , ghc-prim , inline-asm+ , mtl , template-haskell >=2.15.0.0 , uniplate default-language: Haskell2010@@ -68,9 +75,11 @@ build-depends: QuickCheck , base >=4.7 && <5+ , either , ghc-prim , hspec , inline-asm+ , mtl , template-haskell >=2.15.0.0 , uniplate default-language: Haskell2010
src/Language/Asm/Inline.hs view
@@ -1,11 +1,9 @@ {-# LANGUAGE MagicHash #-}-{-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances, FunctionalDependencies #-} {-# LANGUAGE DataKinds, PolyKinds, TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} -module Language.Asm.Inline-( defineAsmFun-) where+module Language.Asm.Inline(defineAsmFun) where import Control.Monad import Data.Generics.Uniplate.Data@@ -14,6 +12,9 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax +import Language.Asm.Inline.AsmCode+import Language.Asm.Inline.Util+ class AsmArg a (rep :: RuntimeRep) (unboxedTy :: TYPE rep) | a -> rep, a -> unboxedTy where unbox :: a -> unboxedTy rebox :: unboxedTy -> a@@ -26,23 +27,25 @@ 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 Double 'DoubleRep Double# where+ unbox (D# d) = d+ rebox = D# -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# )- -}+instance AsmArg Float 'FloatRep Float# where+ unbox (F# f) = f+ rebox = F# -defineAsmFun :: String -> Q Type -> String -> Q [Dec]+defineAsmFun :: AsmCode c => String -> Q Type -> c -> Q [Dec] defineAsmFun name funTyQ asmCode = do addForeignSource LangAsm $ unlines [ ".global " <> asmName , asmName <> ":"- , asmCode+ , codeToString asmCode , "jmp *(%rbp)" ] funTy <- funTyQ+ case validateCode funTy asmCode of+ Right () -> pure ()+ Left err -> error err let importedName = mkName asmName wrapperFunD <- mkFunD name importedName funTy pure@@ -65,7 +68,7 @@ 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 $ UnboxedTupP $ VarP <$> retNames) -> $(pure $ TupE boxing) |] pure $ FunD (mkName funName) [Clause (VarP <$> argNames) (NormalB body) []] where@@ -76,12 +79,11 @@ where unliftBaseTy x | x == ''Word = ''Word# | x == ''Int = ''Int#+ | x == ''Double = ''Double#+ | x == ''Float = ''Float# | otherwise = x unliftTuple (TupleT n) = UnboxedTupleT n unliftTuple x = x--countArgs :: Type -> Int-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),
+ src/Language/Asm/Inline/AsmCode.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE FlexibleInstances #-}++module Language.Asm.Inline.AsmCode where++import Language.Haskell.TH.Syntax++class AsmCode c where+ codeToString :: c -> String+ validateCode :: Type -> c -> Either String ()++instance AsmCode String where+ codeToString = id+ validateCode _ _ = pure ()
+ src/Language/Asm/Inline/QQ.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Asm.Inline.QQ(asm) where++import Control.Arrow+import Control.Monad.Except+import Data.Either.Combinators+import Data.List+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax++import Language.Asm.Inline.AsmCode+import Language.Asm.Inline.Util++instance AsmCode AsmQQParsed where+ codeToString = asmBody+ validateCode ty code =+ check "arguments count mismatch" $ argsCount code == countArgs ty+ where+ check _ True = pure ()+ check str False = throwError $ "Type error: " <> str++asm :: QuasiQuoter+asm = QuasiQuoter { quoteExp = asmQE, quotePat = unsupported, quoteType = unsupported, quoteDec = unsupported }+ where+ unsupported = const $ error "Unsupported quasiquotation type"++asmQE :: String -> Q Exp+asmQE p = case parseAsmQQ p of+ Left err -> error err+ Right parsed -> [e| parsed |]++data AsmQQParsed = AsmQQParsed+ { argsCount :: Int+ , asmBody :: String+ } deriving (Show, Lift)++parseAsmQQ :: String -> Either String AsmQQParsed+parseAsmQQ = findSplitter+ >=> (pure . first words)+ >=> substituteArgs+ where+ findSplitter p = case break (== '|') p of+ (vars, '|' : body) -> pure (vars, body)+ _ -> throwError "Unable to find variable section separator"++substituteArgs :: ([String], String) -> Either String AsmQQParsed+substituteArgs (args, contents) = AsmQQParsed (length args) <$> go contents+ where+ go ('$' : '{' : rest)+ | (arg, '}' : rest') <- break (== '}') rest = do+ idx <- if retPrefix `isPrefixOf` arg+ then pure $ read (drop (length retPrefix) arg)+ else maybeToRight ("Unknown argument: `" <> trim arg <> "`") $ elemIndex (trim arg) args+ reg <- argIdxToReg idx+ (('%' : reg) <>) <$> go rest'+ | otherwise = throwError $ "Unable to parse argument: " <> take 20 rest <> "..."+ go (x : xs) = (x :) <$> go xs+ go [] = pure []++ retPrefix = "ret"++argIdxToReg :: Int -> Either String String+argIdxToReg 0 = pure "rbx"+argIdxToReg 1 = pure "r14"+argIdxToReg 2 = pure "rsi"+argIdxToReg 3 = pure "rdi"+argIdxToReg 4 = pure "r8"+argIdxToReg 5 = pure "r9"+argIdxToReg n = throwError $ "Unsupported register index: " <> show n++trim :: String -> String+trim = pass . pass+ where+ pass = reverse . dropWhile (== ' ')
+ src/Language/Asm/Inline/Util.hs view
@@ -0,0 +1,7 @@+module Language.Asm.Inline.Util where++import Data.Generics.Uniplate.Data+import Language.Haskell.TH.Syntax++countArgs :: Type -> Int+countArgs ty = length $ filter (== ArrowT) $ universeBi ty
test/Spec.hs view
@@ -12,7 +12,7 @@ main :: IO () main = hspec $ do- describe "Basic functions" $ do+ describe "defineAsmFun" $ do it "timesTwo" $ property $ \num -> timesTwo num `shouldBe` num * 2 it "plusWord" $ property $ \n1 n2 -> plusWord n1 n2 `shouldBe` n1 + n2 describe "Returning tuples" $