futhask (empty) → 0.1.0
raw patch · 10 files changed
+950/−0 lines, 10 filesdep +basedep +directorydep +futhasksetup-changed
Dependencies added: base, directory, futhask, raw-strings-qq, split
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +66/−0
- Setup.hs +2/−0
- app/Main.hs +45/−0
- futhask.cabal +52/−0
- src/Backends.hs +3/−0
- src/CodeBodies.hs +459/−0
- src/Conversion.hs +174/−0
- src/Headers.hs +116/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for futhask++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Gusten Isfeldt (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 Gusten Isfeldt 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.
+ README.md view
@@ -0,0 +1,66 @@+# Futhask+Futhask is a code generator that aims to create safe, Haskell friendly wrappers for Futhark libraries.++## Installation+ stack install++## Use+### Generate Code+ futhask [Backend] [Futhark.h] [HaskellSourceDir] [ModuleName]++#### Example+ futhark opencl --library myprogram.fut+ futhask opencl myprogram.h src MyLibrary++For a simple example of how generated haskell code can be used, see [FuthaskExample](https://gitlab.com/Gusten_Isfeldt/futhaskexample)++### Import Code+ import [ModuleName]+ import [ModuleName].Entries+ +If using `stack` add `c-sources: [Futhark.c]` to the `library` section of `package.yaml`++#### OpenCL+ extra-libraries: OpenCL ++#### CUDA+ include-dirs: /opt/cuda/include+ extra-lib-dirs: /opt/cuda/lib+ extra-libraries: cuda cudart nvrtc++### Dependencies+`massiv` is required for all backends.+The codes generated for OpenCL and CUDA, both refer to types from the `OpenCL` and `cuda` packages respectively. This is only relevant if one wants to use certain functions in the raw interface, but, without modification, the generated code will not compile without these dependencies.++## Generated Code+The generated code can be split in two main parts, raw and wrapped. The raw interface is simply the C-functions wrapped in the IO-monad, providing no added safety and requiring manual memory management. The wrapped interface uses `newForeignPtr` to introduce all Futhark pointers to the GC, and provides function types closer to those used within Futhark, returning tuples instead of writing to pointers.++### Context Generation+ getContext :: [ContextOption] -> IO Context++Available context options will depend on backend used.++### The FT monad+To make the wrappers safe, and reduce clutter from explicitly passing around the context, the FT monad is introduced. The FT monad is an environment (Reader) monad that implicitly passes the context around as necessary. Like the ST monad, the FT monad is parameterised by a rigid type variable to prevent references to the context from escaping the monad.++To run computations, the function++ runFTIn :: Context -> (forall c. FT c a) -> a++is used. Additionally++ runFTWith :: [ContextOption] -> (forall c. FT c a) -> a+ runFT :: (forall c. FT c a) -> a++are defined for convienience for cases where the context doesn't need to be reused.++### Input and Output+For conversion between Futhark values and Haskell values, two classes are defined.++ class Input fo ho where+ toFuthark :: ho -> FT c (fo c) ++ class Output fo ho where+ fromFuthark :: fo c -> FT c ho++Instances of Input and Output are generated for all transparent Futhark-arrays. The Haskell representation is `Array S` from `Data.Massiv.Array`. The absence of functional dependencies in the definitions might require more explicit type signatures, but gives more flexibility to define new instances. For tuples of instances, functions on the form `fromFutharkTN`, where `N` is the tuple size, are defined.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,45 @@+module Main where++import System.IO+import Data.Maybe+import Data.List (intercalate)+import Debug.Trace+import System.Directory+import System.Environment+import CodeBodies+import Conversion+import Headers+import Backends++writeModule backend directory moduleName (subModuleName, headerF, body) + = writeFile fn string+ where fn = directory ++ "/" ++ moduleName + ++ (case subModuleName of Just n -> "/" ++ n; Nothing -> "") ++ ".hs"+ string = headerF backend moduleName subModuleName ++ body++main :: IO ()+main = do+ args <- getArgs+ [ backendS, headerName, srcDir, moduleName ] <- getArgs >>= \args -> case args of+ [a, b, c, d] -> return args+ _ -> error "futhask takes four arguments:\n - backend (c, opencl, cuda)\n - Futhark header file\n - Haskell source directory\n - module name"+ backend <- case backendS of+ "c" -> return C+ "opencl" -> return OpenCL+ "cuda" -> return Cuda+ _ -> error $ "unknown backend: " ++ backendS ++ "\n available backends: c, opencl, cuda"+ header <- readHeader headerName+ + createDirectoryIfMissing False (srcDir ++ "/" ++ moduleName)+ mapM_ (writeModule backend srcDir moduleName)+ [ (Just "Raw", rawHeader, rawImportString header)+ , (Just "Entries", entriesHeader, entryCallString header)+ , (Just "Types", typesHeader, instanceDeclarationString header)+ , (Just "TypeClasses", typeClassesHeader, typeClassesBody)+ , (Just "Context", contextHeader, contextBody)+ , (Just "Config", configHeader, configBody backend)+ , (Just "FT", fTHeader, fTBody)+ , (Just "Wrap", wrapHeader, wrapBody)+ , (Just "Utils", utilsHeader, utilsBody)+ , (Nothing, exportsHeader, "") ]+
+ futhask.cabal view
@@ -0,0 +1,52 @@+cabal-version: 1.12++name: futhask+version: 0.1.0+synopsis: Generate Haskell wrappers for Futhark libraries+description: Please see the README on GitLab at <https://gitlab.com/Gusten_Isfeldt/futhask#futhask>+category: FFI Tools+author: Gusten Isfeldt+maintainer: isfeldt@kth.se+copyright: 2020, Gusten Isfeldt+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://gitlab.com/Gusten_Isfeldt/futhask.git++library+ exposed-modules:+ Backends+ CodeBodies+ Conversion+ Headers+ other-modules:+ Paths_futhask+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <4.15+ , directory >=1.3.3 && <1.4+ , raw-strings-qq >=1.1 && <1.2+ , split >=0.2.3 && <0.3+ default-language: Haskell2010++executable futhask+ main-is: Main.hs+ other-modules:+ Paths_futhask+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base+ , directory+ , futhask+ , raw-strings-qq+ , split+ default-language: Haskell2010
+ src/Backends.hs view
@@ -0,0 +1,3 @@+module Backends where++data Backend = C | OpenCL | Cuda
+ src/CodeBodies.hs view
@@ -0,0 +1,459 @@+{-# LANGUAGE QuasiQuotes #-}+++module CodeBodies where+import Text.RawString.QQ+import Backends++typeClassesBody = [r|+class FutharkObject wrapped raw | wrapped -> raw, raw -> wrapped where+ wrapFO :: ForeignPtr raw -> wrapped c+ freeFO :: Ptr Raw.Futhark_context -> Ptr raw -> IO Int+ withFO :: wrapped c -> (Ptr raw -> IO b) -> IO b+ +++class (FutharkObject array rawArray, Storable element, M.Index dim) + => FutharkArray array rawArray dim element + | array -> dim, array -> element + where+ shapeFA :: Ptr Raw.Futhark_context -> Ptr rawArray -> IO (M.Sz dim)+ newFA :: Ptr Raw.Futhark_context -> Ptr element -> M.Sz dim -> IO (Ptr rawArray)+ valuesFA :: Ptr Raw.Futhark_context -> Ptr rawArray -> Ptr element -> IO Int ++class Input fo ho where+ toFuthark :: ho -> FT c (fo c)++class Output fo ho where+ fromFuthark :: fo c -> FT c ho++|]++configBody C = [r|+data ContextOption+ = Debug Int+ | Log Int++setOption config option = case option of+ (Debug flag) -> Raw.context_config_set_debugging config flag+ (Log flag) -> Raw.context_config_set_logging config flag+|]++configBody OpenCL = [r|+data ContextOption+ = BuildOptions [String]+ | Debug Int+ | Profile Int+ | Log Int+ | Device String+ | Platform String+ | LoadProgram String+ | LoadBinary String+ | DumpBinary String+ | DefaultGroupSize Int+ | DefaultGroupNum Int+ | DefaultTileSize Int+ | DefaultThreshold Int+ | Size String CSize++setOption config option = case option of+ (BuildOptions os) -> mapM_ (\o -> withCString o $ Raw.context_config_add_build_option config) os+ (Debug flag) -> Raw.context_config_set_debugging config flag+ (Profile flag) -> Raw.context_config_set_profiling config flag+ (Log flag) -> Raw.context_config_set_logging config flag+ (Device s) -> withCString s $ Raw.context_config_set_device config+ (Platform s) -> withCString s $ Raw.context_config_set_platform config+ (LoadProgram s) -> withCString s $ Raw.context_config_load_program_from config + (LoadBinary s) -> withCString s $ Raw.context_config_load_binary_from config + (DumpBinary s) -> withCString s $ Raw.context_config_dump_binary_to config + (DefaultGroupSize s) -> Raw.context_config_set_default_group_size config s+ (DefaultGroupNum n) -> Raw.context_config_set_default_num_groups config n+ (DefaultTileSize s) -> Raw.context_config_set_default_tile_size config s+ (DefaultThreshold n) -> Raw.context_config_set_default_threshold config n+ (Size name s) -> withCString name $ \n -> Raw.context_config_set_size config n s+ >>= \code -> if code == 0+ then return ()+ else error "invalid size"+|]++configBody Cuda = [r|+data ContextOption+ = NvrtcOptions [String]+ | Debug Int+ | Log Int+ | Device String+ | LoadProgram String+ | DumpProgram String+ | LoadPtx String+ | DumpPtx String+ | DefaultGroupSize Int+ | DefaultGroupNum Int+ | DefaultTileSize Int+ | DefaultThreshold Int+ | Size String CSize++setOption config option = case option of+ (NvrtcOptions os) -> mapM_ (\o -> withCString o $ Raw.context_config_add_nvrtc_option config) os+ (Debug flag) -> Raw.context_config_set_debugging config flag+ (Log flag) -> Raw.context_config_set_logging config flag+ (Device s) -> withCString s $ Raw.context_config_set_device config+ (LoadProgram s) -> withCString s $ Raw.context_config_load_program_from config + (DumpProgram s) -> withCString s $ Raw.context_config_dump_program_to config + (LoadPtx s) -> withCString s $ Raw.context_config_load_ptx_from config + (DumpPtx s) -> withCString s $ Raw.context_config_dump_ptx_to config + (DefaultGroupSize s) -> Raw.context_config_set_default_group_size config s+ (DefaultGroupNum n) -> Raw.context_config_set_default_num_groups config n+ (DefaultTileSize s) -> Raw.context_config_set_default_tile_size config s+ (DefaultThreshold n) -> Raw.context_config_set_default_threshold config n+ (Size name s) -> withCString name $ \n -> Raw.context_config_set_size config n s+ >>= \code -> if code == 0+ then return ()+ else error "invalid size"+|]++contextBody = [r|+data Context = Context (MVar Int) (ForeignPtr Raw.Futhark_context)++getContext :: [ContextOption] -> IO Context+getContext options = do+ config <- Raw.context_config_new+ mapM_ (setOption config) options+ context <- Raw.context_new config+ Raw.context_config_free config+ childCount <- S.newMVar 0+ fmap (Context childCount)+ $ FC.newForeignPtr context + $ (forkIO $ freeContext childCount context)+ >> return ()++freeContext childCount pointer + = readMVar childCount >>= \n + -> if n == 0 + then Raw.context_free pointer + else yield >> freeContext childCount pointer++inContext (Context _ fp) = withForeignPtr fp++getError context = do+ cs <- inContext context Raw.context_get_error+ s <- peekCString cs+ F.free cs+ error s++clearError context = inContext context Raw.context_get_error >>= F.free++clearCache context+ = inContext context Raw.context_clear_caches >>= \code + -> if code == 0 + then return ()+ else getError context++syncContext context + = inContext context Raw.context_sync >>= \code + -> if code == 0 + then return ()+ else getError context++inContextWithError :: Context -> (Ptr Raw.Futhark_context -> IO Int) -> IO ()+inContextWithError context f = do+ code <- attempt+ if code == 0 + then success+ else do+ clearError context+ performGC+ code' <- attempt+ if code' == 0+ then success+ else failure+ where+ attempt = inContext context f+ success = return ()+ failure = getError context++|]+++fTBody = [r|+newtype FT c a = FT (Context -> a)++instance Functor (FT c) where+ fmap f (FT a) = FT (f.a)++instance Applicative (FT c) where+ pure a = FT (\_ -> a)+ (<*>) (FT a) (FT b) = FT (\c -> a c $ b c)++instance Monad (FT c) where+ return = pure + (>>=) (FT a) f = FT (\c -> (\(FT b) -> b c) $ f $ a c)++runFTIn :: Context -> (forall c. FT c a) -> a+runFTIn context (FT a) = a context+++runFTWith :: [ContextOption] -> (forall c. FT c a) -> a+runFTWith options a + = unsafePerformIO + $ getContext options >>= \c -> return $ runFTIn c a +runFT = runFTWith []++unsafeLiftFromIO :: (Context -> IO a) -> FT c a+unsafeLiftFromIO a = FT (\c -> unsafePerformIO $ a c)+|]+++wrapBody = [r|+wrapIn context@(Context childCount pointer) rawObject + = S.modifyMVar_ childCount (return.(+1))+ >> (fmap wrapFO $ FC.newForeignPtr rawObject freeCall)+ where freeCall = (inContextWithError context $ \c -> freeFO c rawObject)+ >> S.modifyMVar_ childCount (return.(+(-1)))++peekFree p = peek p >>= \v -> free p >> return v+peekFreeWrapIn context rawP + = peek rawP >>= wrapIn context >>= \fo -> F.free rawP >> return fo++-- Ptr - Dim conversion++to1d f cP aP+ = f cP aP+ >>= fmap (\[d0] -> M.Sz1 d0)+ . fmap (fmap fromIntegral)+ . peekArray 1++to2d f cP aP+ = f cP aP+ >>= fmap (\[d0, d1] -> M.Sz2 d0 d1)+ . fmap (fmap fromIntegral)+ . peekArray 2++to3d f cP aP+ = f cP aP+ >>= fmap (\[d0, d1, d2] -> M.Sz3 d0 d1 d2)+ . fmap (fmap fromIntegral)+ . peekArray 3++to4d f cP aP+ = f cP aP+ >>= fmap (\[d0, d1, d2, d3] -> M.Sz4 d0 d1 d2 d3)+ . fmap (fmap fromIntegral)+ . peekArray 4++to5d f cP aP+ = f cP aP+ >>= fmap (\[d0, d1, d2, d3, d4] -> M.Sz5 d0 d1 d2 d3 d4)+ . fmap (fmap fromIntegral)+ . peekArray 5+++from1d f cP eP (M.Sz1 d0) = f cP eP (fromIntegral d0)++from2d f cP eP (M.Sz2 d0 d1) = f cP eP (fromIntegral d0)+ (fromIntegral d1)++from3d f cP eP (M.Sz3 d0 d1 d2) = f cP eP (fromIntegral d0)+ (fromIntegral d1)+ (fromIntegral d2)++from4d f cP eP (M.Sz4 d0 d1 d2 d3) = f cP eP (fromIntegral d0)+ (fromIntegral d1)+ (fromIntegral d2)+ (fromIntegral d3)++from5d f cP eP (M.Sz5 d0 d1 d2 d3 d4) = f cP eP (fromIntegral d0)+ (fromIntegral d1)+ (fromIntegral d2)+ (fromIntegral d3)+ (fromIntegral d4)++|]++utilsBody = [r|++instance (FutharkArray array rawArray dim element)+ => Input array (M.Array M.S dim element) where+ toFuthark array = unsafeLiftFromIO $ \context+ -> inContext context $ \c+ -> MU.unsafeWithPtr array (\aP -> newFA c aP $ M.size array)+ >>= wrapIn context++instance (FutharkArray array rawArray dim element)+ => Output array (M.Array M.S dim element) where+ fromFuthark array = unsafeLiftFromIO $ \context+ -> inContext context $ \c+ -> withFO array $ \aP+ -> do+ syncContext context+ shape <- shapeFA c aP+ pointer <- mallocForeignPtrArray $ M.totalElem shape+ withForeignPtr pointer $ valuesFA c aP+ return $ M.resize' shape+ $ MU.unsafeArrayFromForeignPtr0 M.Seq pointer+ $ M.Sz1 (M.totalElem shape)++fromFutharkT2 (a, b) = do+ a' <- fromFuthark a+ b' <- fromFuthark b+ return (a', b')++fromFutharkT3 (a, b, c) = do+ a' <- fromFuthark a+ b' <- fromFuthark b+ c' <- fromFuthark c+ return (a', b', c')++fromFutharkT4 (a, b, c, d) = do+ a' <- fromFuthark a+ b' <- fromFuthark b+ c' <- fromFuthark c+ d' <- fromFuthark d+ return (a', b', c', d')++fromFutharkT5 (a, b, c, d, e) = do+ a' <- fromFuthark a+ b' <- fromFuthark b+ c' <- fromFuthark c+ d' <- fromFuthark d+ e' <- fromFuthark e+ return (a', b', c', d', e')++fromFutharkT6 (a, b, c, d, e, f) = do+ a' <- fromFuthark a+ b' <- fromFuthark b+ c' <- fromFuthark c+ d' <- fromFuthark d+ e' <- fromFuthark e+ f' <- fromFuthark f+ return (a', b', c', d', e', f')++fromFutharkT7 (a, b, c, d, e, f, g) = do+ a' <- fromFuthark a+ b' <- fromFuthark b+ c' <- fromFuthark c+ d' <- fromFuthark d+ e' <- fromFuthark e+ f' <- fromFuthark f+ g' <- fromFuthark g+ return (a', b', c', d', e', f', g')+++toFutharkT2 (a, b) = do+ a' <- toFuthark a+ b' <- toFuthark b+ return (a', b')++toFutharkT3 (a, b, c) = do+ a' <- toFuthark a+ b' <- toFuthark b+ c' <- toFuthark c+ return (a', b', c')++toFutharkT4 (a, b, c, d) = do+ a' <- toFuthark a+ b' <- toFuthark b+ c' <- toFuthark c+ d' <- toFuthark d+ return (a', b', c', d')++toFutharkT5 (a, b, c, d, e) = do+ a' <- toFuthark a+ b' <- toFuthark b+ c' <- toFuthark c+ d' <- toFuthark d+ e' <- toFuthark e+ return (a', b', c', d', e')++toFutharkT6 (a, b, c, d, e, f) = do+ a' <- toFuthark a+ b' <- toFuthark b+ c' <- toFuthark c+ d' <- toFuthark d+ e' <- toFuthark e+ f' <- toFuthark f+ return (a', b', c', d', e', f')++toFutharkT7 (a, b, c, d, e, f, g) = do+ a' <- toFuthark a+ b' <- toFuthark b+ c' <- toFuthark c+ d' <- toFuthark d+ e' <- toFuthark e+ f' <- toFuthark f+ g' <- toFuthark g+ return (a', b', c', d', e', f', g')++|]++{--+instance (Output a a', Output b b')+ => Output (a, b) (a', b') where+ fromFuthark (a, b) = do+ a' <- fromFuthark a+ b' <- fromFuthark b+ return (a', b')++instance (Output a a', Output b b', Output c c')+ => Output (a, b, c) (a', b', c') where+ fromFuthark (a, b, c) = do+ a' <- fromFuthark a+ b' <- fromFuthark b+ c' <- fromFuthark c+ return (a', b', c')++instance (Output a a', Output b b', Output c c', Output d d')+ => Output (a, b, c, d) (a', b', c', d') where+ fromFuthark (a, b, c, d) = do+ a' <- fromFuthark a+ b' <- fromFuthark b+ c' <- fromFuthark c+ d' <- fromFuthark d+ return (a', b', c', d')++instance (Output a a', Output b b', Output c c', Output d d', Output e e')+ => Output (a, b, c, d, e) (a', b', c', d', e') where+ fromFuthark (a, b, c, d, e) = do+ a' <- fromFuthark a+ b' <- fromFuthark b+ c' <- fromFuthark c+ d' <- fromFuthark d+ e' <- fromFuthark e+ return (a', b', c', d', e')+++instance (Input a a', Input b b')+ => Input (a, b) (a', b') where+ toFuthark (a, b) = do+ a' <- toFuthark a+ b' <- toFuthark b+ return (a', b')++instance (Input a a', Input b b', Input c c')+ => Input (a, b, c) (a', b', c') where+ toFuthark (a, b, c) = do+ a' <- toFuthark a+ b' <- toFuthark b+ c' <- toFuthark c+ return (a', b', c')++instance (Input a a', Input b b', Input c c', Input d d')+ => Input (a, b, c, d) (a', b', c', d') where+ toFuthark (a, b, c, d) = do+ a' <- toFuthark a+ b' <- toFuthark b+ c' <- toFuthark c+ d' <- toFuthark d+ return (a', b', c', d')++instance (Input a a', Input b b', Input c c', Input d d', Input e e')+ => Input (a, b, c, d, e) (a', b', c', d', e') where+ toFuthark (a, b, c, d, e) = do+ a' <- toFuthark a+ b' <- toFuthark b+ c' <- toFuthark c+ d' <- toFuthark d+ e' <- toFuthark e+ return (a', b', c', d', e')+--}++
+ src/Conversion.hs view
@@ -0,0 +1,174 @@+module Conversion where++import Data.Maybe+import Data.List (intercalate, partition, lookup)+import Data.Char (toUpper)+import Text.ParserCombinators.ReadP++data HeaderItem + = Preproc String+ | Comment String+ | Fun (String, String) [(String, String)]+ | Var (String, String)+ deriving Show+++isWhiteSpace = (flip elem) " \t\n"+isNameChar = not.(flip elem) " \t\n;,()"+readPreproc = fmap Preproc $ (char '#') >> manyTill get (char '\n')+readComment = fmap Comment $ (string "/*") >> manyTill get (string "*/")+readOnelineComment = fmap Comment $ (string "//") >> manyTill get (char '\n')+readTypeName = skipSpaces+ >> sepBy (munch1 (isNameChar)) (skipMany1 $ satisfy isWhiteSpace) >>= \ws + -> case ws of+ [] -> return ("void", "")+ [a] -> return (a, "")+ a -> return ( intercalate " " (init a) ++ takeWhile (=='*') (last a)+ , dropWhile (=='*') (last a) )+ +readVar = readTypeName >>= \tn -> skipSpaces >> char ';' >> return (Var tn)+readFun = readTypeName >>= \tn + -> skipSpaces + >> char '(' >> sepBy readTypeName (char ',') >>= \args -> char ')' + >> skipSpaces >> char ';' + >> return (Fun tn args)+++readHeaderItem = skipSpaces >> readPreproc <++ readComment <++ readOnelineComment <++ readFun <++ readVar+readHeader fn = fmap (fst . head + . (readP_to_S $ many readHeaderItem >>= \his + -> skipSpaces >> eof >> return his)) + $ readFile fn++varTable = + [ ("int", "Int")+ , ("float", "Float")+ , ("double", "Double")+ , ("char", "CChar")+ , ("bool", "CBool")+ , ("void", "()")+ , ("int8_t" , "Int8")+ , ("int16_t", "Int16")+ , ("int32_t", "Int32")+ , ("int64_t", "Int64")+ , ("uint8_t" , "Word8")+ , ("uint16_t", "Word16")+ , ("uint32_t", "Word32")+ , ("uint64_t", "Word64")+ , ("size_t", "CSize")+ , ("cl_mem", "CLMem")+ , ("cl_command_queue", "CLCommandQueue")+ , ("CUdeviceptr", "DevicePtr ()") ]++varTable2 = + [ ("f32", "Float")+ , ("f64", "Double")+ , ("bool", "CBool")+ , ("i8" , "Int8")+ , ("i16", "Int16")+ , ("i32", "Int32")+ , ("i64", "Int64")+ , ("u8" , "Word8")+ , ("u16", "Word16")+ , ("u32", "Word32")+ , ("u64", "Word64") ]++capitalize (c:cs) = toUpper c:cs+wrapIfNotOneWord s = if elem ' ' s then "(" ++ s ++ ")" else s+haskellType s = + let pn = length $ dropWhile (/='*') s+ ts = dropWhile (=="const") $ words $ takeWhile (/='*') s+ in (intercalate "(" $ replicate pn "Ptr ") + ++ (if head ts == "struct" + then capitalize $ ts !! 1+ else (case lookup (head ts) varTable of + Just s -> s; + Nothing -> error $ "type \'" ++ s ++ "\' not found";))+ ++ replicate (pn-1) ')'++haskellDeclaration (Preproc s) = ""+haskellDeclaration (Comment s) + = intercalate "\n" + $ map (("--"++).dropWhile (==' ')) $ filter (/="") $ lines s +haskellDeclaration (Var (_, n)) = "data " ++ capitalize n+haskellDeclaration (Fun (ot, name) args) + = "foreign import ccall unsafe \"" ++ name ++ "\"\n "+ ++ drop 8 name ++ "\n :: "+ ++ intercalate "\n -> " + ( (map haskellType $ filter (/="void") $ map fst args)+ ++ ["IO " ++ wrapIfNotOneWord (haskellType ot)] )+ ++ "\n"++rawImportString headerItems = intercalate "\n" $ map haskellDeclaration headerItems++instanceDeclarations (Var (_, n))+ = (if isObject then objectString else "") + ++ (if isArray then arrayString else "")+ where cn = capitalize sn+ rn = capitalize n+ sn = drop 8 n+ isObject = take 7 sn /= "context" + isArray = isObject && take 6 sn /= "opaque"+ dim = if isArray + then read $ (:[]) $ last $ init sn+ else 0+ element = if isArray+ then case lookup (takeWhile (/= '_') sn) varTable2 of+ (Just t) -> t+ Nothing -> error $ "ArrayType" ++ sn ++ " not found."+ else ""+ arrayString = "instance FutharkArray "++ cn ++ " Raw."++ rn + ++ " M.Ix" ++ show dim ++ " " ++ element ++ " where\n"+ ++ " shapeFA = to" ++ show dim ++ "d Raw.shape_" ++ sn ++ "\n"+ ++ " newFA = from" ++ show dim ++ "d Raw.new_" ++ sn ++ "\n"+ ++ " valuesFA = Raw.values_" ++ sn ++ "\n"+ objectString = "\nnewtype " ++ cn ++ " c = " ++ cn ++ " (F.ForeignPtr Raw." ++ rn ++ ")\n"+ ++ "instance FutharkObject " ++ cn ++ " Raw." ++ rn ++ " where\n"+ ++ " wrapFO = " ++ cn ++ "\n"+ ++ " freeFO = Raw.free_" ++ sn ++ "\n"+ ++ " withFO (" ++ cn ++ " fp) = F.withForeignPtr fp\n"+ nfdataString = "instance NFData (" ++ cn ++" c) where rnf = rwhnf"++instanceDeclarations _ = ""++instanceDeclarationString headerItems = concatMap instanceDeclarations headerItems++haskellType' s = + let pn = length $ dropWhile (/='*') s+ ts = dropWhile (=="const") $ words $ takeWhile (/='*') s+ in if head ts == "struct" + then capitalize (drop 8 $ ts !! 1) ++ " c"+ else (case lookup (head ts) varTable of + Just s -> s; + Nothing -> error $ "type " ++ s ++ "not found";)++entryCall (Fun (_, n) args) + = if isEntry + then "\n" ++ typeDeclaration ++ input ++ preCall ++ call ++ postCall+ else ""+ where+ sn = drop 8 n+ isEntry = take 5 sn == "entry"+ en = drop 6 sn+ isFO a = case lookup (takeWhile (/='*') $ last $ words $ fst a) varTable + of Just _ -> False; Nothing -> True; + (inArgs, outArgs) = partition ((=="in").take 2.snd) $ tail args+ typeDeclaration = en ++ "\n :: " + ++ concatMap (\i -> haskellType' (fst i) ++ "\n -> " ) inArgs+ ++ "FT c " ++ wrapIfNotOneWord (intercalate ", " $ map (\o -> haskellType' $ fst o) outArgs) ++ "\n"+ input = unwords (en : map snd inArgs) ++ "\n = FT.unsafeLiftFromIO $ \\context\n -> "+ preCall = concat + $ map (\i -> "T.withFO " ++ snd i ++ " $ \\" ++ snd i ++ "'\n -> ") (filter isFO inArgs)+ ++ map (\o -> "F.malloc >>= \\" ++ snd o ++ "\n -> ") outArgs + call = "C.inContextWithError context (\\context'\n -> Raw." ++ sn ++ " context' " + ++ unwords ((map snd $ outArgs) ++ (map (\i -> if isFO i then snd i ++ "'" else snd i) inArgs)) ++ ")\n >> "+ peek o = if isFO o then "U.peekFreeWrapIn context " else "U.peekFree "+ postCall = (if length outArgs > 1+ then concatMap (\o -> peek o ++ snd o ++ " >>= \\" ++ snd o ++ "'\n -> ") outArgs+ ++ "return " ++ wrapIfNotOneWord (intercalate ", " $ map (\o -> snd o ++ "'") outArgs)+ else peek (head outArgs) ++ snd (head outArgs))+ ++ "\n"++entryCall _ = ""+ +entryCallString headerItems = concatMap entryCall headerItems
+ src/Headers.hs view
@@ -0,0 +1,116 @@++module Headers where+import Data.List (intercalate)+import Backends++data Import = N String | Q String String++globalImport (N m) = "import " ++ m ++ "\n"+globalImport (Q m a) = "import qualified " ++ m ++ " as " ++ a ++ "\n"+localImport moduleName (N sub) = globalImport $ N (moduleName ++ "." ++ sub)+localImport moduleName (Q sub a) = globalImport $ Q (moduleName ++ "." ++ sub) a++haskellHeader exports extensions localImports globalImports moduleName subModuleName + = (if length extensions > 0 + then "{-# LANGUAGE " ++ intercalate ", " extensions ++ " #-}" + else "")+ ++ "\nmodule " + ++ moduleName ++ (case subModuleName of Nothing -> ""; Just n -> '.':n)+ ++ (if length exports > 0 then " (" ++ intercalate ", " exports ++ ")" else "")+ ++ " where\n"+ ++ concatMap (localImport moduleName) localImports+ ++ concatMap globalImport globalImports++specific C = []+specific OpenCL = [N "Control.Parallel.OpenCL (CLMem, CLCommandQueue)"]+specific Cuda = [N "Foreign.CUDA.Ptr(DevicePtr(..))"]++rawHeader backend = haskellHeader+ []+ [ "ForeignFunctionInterface" ]+ [] + ( [ N "Data.Int (Int8, Int16, Int32, Int64)"+ , N "Data.Word (Word8, Word16, Word32, Word64)"+ , N "Foreign.C.Types (CBool(..), CSize(..), CChar(..))"+ , N "Foreign.Ptr (Ptr)" ] ++ specific backend )++typeClassesHeader backend = haskellHeader+ [ "FutharkObject", "FutharkArray"+ , "freeFO", "withFO", "wrapFO", "newFA", "shapeFA", "valuesFA"+ , "Input", "Output"+ , "fromFuthark", "toFuthark" ]+ [ "MultiParamTypeClasses", "FunctionalDependencies", "TypeSynonymInstances" ]+ [ Q "Raw" "Raw", N "FT" ] + [ N "Foreign", Q "Data.Massiv.Array" "M" ]++configHeader backend = haskellHeader+ []+ []+ [ Q "Raw" "Raw" ]+ ( [ N "Foreign.C" ] ++ specific backend )++contextHeader backend = haskellHeader+ []+ []+ [Q "Raw" "Raw", N "Config" ]+ [N "Foreign as F", Q "Foreign.Concurrent" "FC", N "Foreign.C", N "Control.Concurrent", Q "Control.Concurrent.MVar.Strict" "S", N "System.Mem (performGC)"]++fTHeader backend = haskellHeader+ [ "FT", "runFTIn", "runFTWith", "runFT", "unsafeLiftFromIO" ]+ [ "RankNTypes", "ExistentialQuantification" ]+ [ N "Context", N "Config" ]+ [ N "System.IO.Unsafe" ]++wrapHeader backend = haskellHeader+ []+ [ "RankNTypes"+ , "FlexibleInstances"+ , "MultiParamTypeClasses"+ , "UndecidableInstances" ]+ [ Q "Raw" "Raw", N "Context", N "FT", N "TypeClasses" ]+ [ N "Foreign as F", Q "Foreign.Concurrent" "FC", N "Foreign.C"++ , Q "Data.Massiv.Array" "M", Q "Data.Massiv.Array.Unsafe" "MU", Q "Control.Concurrent.MVar.Strict" "S" ]++typesHeader backend = haskellHeader+ []+ [ "RankNTypes", "ExistentialQuantification"+ , "MultiParamTypeClasses", "TypeSynonymInstances", "FlexibleInstances" ]+ [ Q "Raw" "Raw", N "Wrap", N "TypeClasses" ]+ [ Q "Foreign" "F", Q "Data.Massiv.Array" "M"+ , N "Data.Int (Int8, Int16, Int32, Int64)"+ , N "Data.Word (Word8, Word16, Word32, Word64)"+ , N "Foreign.C.Types (CBool(..), CSize(..), CChar(..))"+ , N "Foreign.Ptr (Ptr)"+ , N "Control.DeepSeq (rwhnf)" ]++entriesHeader backend = haskellHeader+ []+ []+ [ Q "Raw" "Raw", Q "Context" "C", N "FT (FT)", Q "FT" "FT"+ , Q "Wrap" "U", N "Types", Q "TypeClasses" "T" ]+ [ N "Data.Int (Int8, Int16, Int32, Int64)"+ , N "Data.Word (Word8, Word16, Word32, Word64)" + , Q "Foreign" "F", N "Foreign.C.Types" ]+++utilsHeader backend =haskellHeader+ []+ [ "RankNTypes"+ , "FlexibleInstances"+ , "MultiParamTypeClasses"+ , "UndecidableInstances" ]+ [ Q "Raw" "Raw", N "Context", N "FT", N "TypeClasses", N "Wrap" ]+ [ N "Foreign as F", Q "Foreign.Concurrent" "FC", N "Foreign.C"++ , Q "Data.Massiv.Array" "M", Q "Data.Massiv.Array.Unsafe" "MU" ]++exportsHeader backend = haskellHeader+ [ "module F" ]+ []+ [ N "Context as F"+ , N "Config as F hiding (setOption)"+ , N "TypeClasses as F hiding (FutharkObject, FutharkArray)"+ , N "Utils as F"+ , N "FT as F" ]+ []