diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,47 @@ +====================================================================== +Haskell LLVM Bindings Release License +====================================================================== +University of Illinois/NCSA +Open Source License + +Copyright (c) 2014-2016 Henning Thielemann +Copyright (c) 2007-2009 Bryan O'Sullivan +All rights reserved. + +Developed by: + + Henning Thielemann + + Bryan O'Sullivan + http://www.serpentine.com/blog/ + + Lennart Augustsson + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal with the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimers. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimers in the documentation and/or other materials provided + with the distribution. + + * Neither the names of Bryan O'Sullivan, University of Illinois at + Urbana-Champaign, nor the names of its contributors may be used + to endorse or promote products derived from this Software + without specific prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR +ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF +CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/llvm-ffi-tools.cabal b/llvm-ffi-tools.cabal new file mode 100644 --- /dev/null +++ b/llvm-ffi-tools.cabal @@ -0,0 +1,65 @@ +Name: llvm-ffi-tools +Version: 0.0.1 +License: BSD3 +License-File: LICENSE +Synopsis: Tools for maintaining the llvm-ffi package +Description: + The package contains tools for maintaining the FFI interface to LLVM + in the @llvm-ffi@ package + . + Most notably there is the @llvm-function-mangler@ + that converts LLVM-C bindings to Haskell foreign imports. +Author: Henning Thielemann, Bryan O'Sullivan, Lennart Augustsson +Maintainer: Henning Thielemann +Homepage: http://haskell.org/haskellwiki/LLVM +Stability: experimental +Category: Compilers/Interpreters, Code Generation +Tested-With: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==8.0.1 +Cabal-Version: >= 1.10 +Build-Type: Simple + +Source-Repository head + Type: darcs + Location: https://hub.darcs.net/thielema/llvm-ffi-tools/ + +Source-Repository this + Tag: 0.0.1 + Type: darcs + Location: https://hub.darcs.net/thielema/llvm-ffi-tools/ + +Executable llvm-diff-ffi + Build-Depends: + utility-ht >=0.0.9 && <0.1, + regex-posix >=0.95 && <0.97, + containers >=0.4 && <0.7, + base >=4.5 && <5 + + Hs-Source-Dirs: src + GHC-Options: -Wall + Default-Language: Haskell98 + Main-Is: DiffFFI.hs + Other-Modules: FunctionMangulation + +Executable llvm-function-mangler + Build-Depends: + utility-ht >=0.0.9 && <0.1, + regex-posix >=0.95 && <0.97, + containers >=0.4 && <0.7, + base >=4.5 && <5 + + Hs-Source-Dirs: src + GHC-Options: -Wall + Default-Language: Haskell98 + Main-Is: FunctionMangler.hs + Other-Modules: FunctionMangulation + +Executable llvm-intrinsic-mangler + Build-Depends: + bytestring >=0.9 && <0.13, + regex-posix >=0.95 && <0.97, + base >=4.5 && <5 + + Hs-Source-Dirs: src + GHC-Options: -Wall + Default-Language: Haskell98 + Main-Is: IntrinsicMangler.hs diff --git a/src/DiffFFI.hs b/src/DiffFFI.hs new file mode 100644 --- /dev/null +++ b/src/DiffFFI.hs @@ -0,0 +1,46 @@ +module Main (main) where + +import FunctionMangulation (pattern, rewriteFunction) + +import Text.Regex.Posix ((=~)) + +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe (mapMaybe) + +import Control.Monad (forM_) + +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) + + +cFunctions :: String -> Map String String +cFunctions s = + let f (_:ret:name:params:_) = + Just ("LLVM" ++ name, rewriteFunction ret name params) + f _ = Nothing + in Map.fromList $ mapMaybe f (s =~ pattern) + +hsFunctions :: String -> Map String String +hsFunctions s = + let pat = "\"([a-zA-Z0-9_]+)\"[ \t\n]+([a-zA-Z0-9_']+)" + f (_:cname:hsname:_) = Just (cname, hsname) + f _ = Nothing + in Map.fromList $ mapMaybe f (s =~ pat) + +main :: IO () +main = do + args <- getArgs + case args of + [cFile, hsFile] -> do + c <- cFunctions `fmap` readFile cFile + hs <- hsFunctions `fmap` readFile hsFile + putStrLn "In C, not Haskell:" + forM_ (Map.toAscList $ Map.difference c hs) $ \(_, hsfunc) -> + putStrLn hsfunc + putStrLn "In Haskell, not C:" + forM_ (Map.keys $ Map.difference hs c) $ putStrLn . (" "++) + _ -> do + hPutStrLn stderr "Usage: DiffFFI cFile hsFile" + exitFailure diff --git a/src/FunctionMangler.hs b/src/FunctionMangler.hs new file mode 100644 --- /dev/null +++ b/src/FunctionMangler.hs @@ -0,0 +1,9 @@ +module Main (main) where + +import FunctionMangulation (rewrite) + +import Data.List (intercalate) + + +main :: IO () +main = interact (intercalate "\n\n" . concat . rewrite) >> putStr "\n" diff --git a/src/FunctionMangulation.hs b/src/FunctionMangulation.hs new file mode 100644 --- /dev/null +++ b/src/FunctionMangulation.hs @@ -0,0 +1,75 @@ +module FunctionMangulation + ( + pattern + , rewrite + , rewriteFunction + ) where + +import Text.Regex.Posix ((=~), (=~~)) + +import Control.Monad (forM) + +import qualified Data.List.HT as ListHT +import Data.Char (toLower) +import Data.List.HT (maybePrefixOf) +import Data.String.HT (trim) +import Data.List (intercalate) + + +pattern :: String +pattern = "^([A-Za-z0-9_ ]+ ?\\*?)[ \t\n]*" ++ + "LLVM([A-Za-z0-9_]+)\\(([][a-zA-Z0-9_*, \t\n]+)\\);" + +renameType :: String -> String +renameType t = + case maybePrefixOf "LLVM" t of + Just suffix -> rename suffix + Nothing -> rename t + +rename :: String -> String +rename cname = + case cname of + "Bool" -> "LLVM.Bool" + "int" -> "CInt" + "unsigned" -> "CUInt" + "const unsigned" -> "CUInt" + "long long" -> "CLLong" + "unsigned long long" -> "CULLong" + "void" -> "()" + "const char *" -> "CString" + "float" -> "CFloat" + "double" -> "CDouble" + "char *" -> "CString" + "size_t" -> "CSize" + "uint8_t" -> "Word8" + "uint16_t" -> "Word16" + "uint32_t" -> "Word32" + "uint64_t" -> "Word64" + "const uint64_t []" -> "Ptr Word64" + _ -> + case ListHT.viewR cname of + Just (ps,'*') -> "(Ptr " ++ rename (trim ps) ++ ")" + _ -> trim cname + +dropName :: String -> String +dropName s = + case s =~ "^((const )?(unsigned long long|[A-Za-z0-9_]+)( \\*+)?) ?[A-Za-z0-9_]*(\\[\\])?$" of + ((_:typ:_:_:_:"[]":_):_) -> typ ++ " []" + ((_:typ:_):_) -> typ + _ -> "{- oops! -} " ++ s + +rewriteFunction :: String -> String -> String -> String +rewriteFunction cret cname cparams = + let ret = "IO " ++ renameType (trim cret) + renameParam = renameType . dropName . trim + params = map renameParam . ListHT.chop (==',') $ cparams + params' = if params == ["()"] then [] else params + name = let (n:ame) = cname in toLower n : ame + in "foreign import ccall unsafe \"LLVM" ++ cname ++ "\" " ++ name ++ + "\n :: " ++ intercalate " -> " (params' ++ [ret]) + +rewrite :: String -> [[String]] +rewrite s = do + matches <- s =~~ pattern + forM matches $ \(_:cret:cname:cparams:_) -> + return (rewriteFunction cret cname cparams) diff --git a/src/IntrinsicMangler.hs b/src/IntrinsicMangler.hs new file mode 100644 --- /dev/null +++ b/src/IntrinsicMangler.hs @@ -0,0 +1,23 @@ +module Main (main) where + +import qualified Data.ByteString.Char8 as C +import Text.Regex.Posix ((=~~)) +import Control.Monad (forM_) +import Data.Maybe (catMaybes) + + +maybeName :: C.ByteString -> Maybe C.ByteString +maybeName line = do + ((_:name:_):_) <- line =~~ "^[ \t]*([a-z0-9_]+),[ \t]*//[ \t]*llvm\\." + return name + +main :: IO () +main = do + input <- (catMaybes . map maybeName . C.lines) `fmap` C.getContents + + putStrLn "-- automatically generated file - do not edit!" + putStrLn "module LLVM.Core.Intrinsics (Intrinsic(..)) where" + putStrLn "data Intrinsic =" + putStrLn " NotIntrinsic" + forM_ input $ C.putStrLn . (C.append (C.pack " | I_")) + putStrLn " deriving (Eq, Ord, Enum, Show)"