diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for inline-asm + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Georg Rudoy (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Georg Rudoy nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +# inline-asm + +_When inline C is too safe_. + +Did you try `inline-c`, but it's not enough? You need more? Nothing seems to satisfy? +`inline-asm` to the rescue! diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes #-} + +module Main where + +import Language.Asm.Inline + +defineAsmFun "foobar" [t| Word -> Word |] "add %rbx, %rbx" + +main :: IO () +main = print $ foobar 21 diff --git a/inline-asm.cabal b/inline-asm.cabal new file mode 100644 --- /dev/null +++ b/inline-asm.cabal @@ -0,0 +1,74 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: e27b467c99b6f79a5aa43f7fbfa55f44eca8495e93b7a08b9c9ce2a09d17cbd0 + +name: inline-asm +version: 0.1.0.0 +synopsis: Inline some Assembly in ur Haskell! +description: Please see the README on GitHub at +category: FFI +homepage: https://github.com/0xd34df00d/inline-asm#readme +bug-reports: https://github.com/0xd34df00d/inline-asm/issues +author: Georg Rudoy +maintainer: 0xd34df00d@gmail.com +copyright: 2020 Georg Rudoy +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/0xd34df00d/inline-asm + +library + exposed-modules: + Language.Asm.Inline + other-modules: + Paths_inline_asm + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , ghc-prim + , template-haskell >=2.15.0.0 + , uniplate + default-language: Haskell2010 + +executable inline-asm-exe + main-is: Main.hs + other-modules: + Paths_inline_asm + hs-source-dirs: + app + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , ghc-prim + , inline-asm + , template-haskell >=2.15.0.0 + , uniplate + default-language: Haskell2010 + +test-suite inline-asm-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_inline_asm + hs-source-dirs: + test + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , ghc-prim + , inline-asm + , template-haskell >=2.15.0.0 + , uniplate + default-language: Haskell2010 diff --git a/src/Language/Asm/Inline.hs b/src/Language/Asm/Inline.hs new file mode 100644 --- /dev/null +++ b/src/Language/Asm/Inline.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.Asm.Inline where + +import Control.Monad +import Data.Generics.Uniplate.Data +import GHC.Prim +import GHC.Types hiding (Type) +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 + +instance AsmArg Int 'IntRep Int# where + unbox (I# w) = w + rebox = I# + +instance AsmArg Word 'WordRep Word# where + unbox (W# w) = w + rebox = W# + +defineAsmFun :: String -> Q Type -> String -> Q [Dec] +defineAsmFun name funTyQ asmCode = do + addForeignSource LangAsm $ unlines [ ".global " <> asmName + , asmName <> ":" + , asmCode + , "jmp *(%rbp)" + ] + funTy <- funTyQ + let importedName = mkName asmName + wrapperFunD <- mkFunD name importedName funTy + pure + [ ForeignD $ ImportF Prim Safe asmName importedName $ unliftType funTy + , SigD (mkName name) funTy + , wrapperFunD + ] + where + 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) |] + 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 + where + f x | x == ''Word = ''Word# + | x == ''Int = ''Int# + | otherwise = x + +countArgs :: Type -> Int +countArgs ty = length [ () | ConT _ <- universeBi ty ] - 1 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"