diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Gusten Isfeldt (c) 2020 +Copyright Gusten Isfeldt (c) 2020-2026 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,108 +2,245 @@ Futhask is a code generator that aims to create safe, Haskell friendly wrappers for Futhark libraries. ## Installation - stack install +```Shell +cabal install futhask +``` -## Use -### Generate Code - futhask [Backend] [Futhark.h] [HaskellSourceDir] [ModuleName] +## Generating code +### Syntax +```Shell +futhask [LIBNAME] [LIBVER] [PROGRAM.c] [PROGRAM.json] [DEST] +``` #### 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) +```Shell +futhark opencl --library myprogram.fut +futhask mylib 1.0 myprogram.c myprogram.json mylibrary +``` -### Import Code - import [ModuleName] - import [ModuleName].Entries +### Using the generated code +To use local libraries, add them to the `cabal.project` -If using `stack` add `c-sources: [Futhark.c]` to the `library` section of `package.yaml` + packages: + DEST/*.cabal + *.cabal + +Then add them as imports in the cabal file as usual +```cabal + ... + build-depends: + ... + mylib + ... +``` +and then -#### OpenCL - extra-libraries: OpenCL +```haskell +import Mylib +``` -#### CUDA - include-dirs: /opt/cuda/include - extra-lib-dirs: /opt/cuda/lib - extra-libraries: cuda cudart nvrtc +to get the basic interface which should be sufficient for many cases. For more granular imports, or if the access to the raw interface is desired, The following submodules are available -### Dependencies -`transformers` and `massiv` are 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. + - `Context` wrapped context instance + - `Monad` Fut monad definition + - `TypeDec` wrapped type declarations + - `TypeOps` instances of various classes for the wrapped types + - `Types` reexports `TypeDec` and `TypeOps` + - `Conversion` instances of `Convertible` + - `EntryPoints` wrapped entry points + - `Raw` simply the C-API imported with the FFI + - `Context` context and config functions + - `TypeDec` raw type declarations + - `TypeOps` type specific utility functions + - `Types` reexports `TypeDec` and `TypeOps` + - `EntryPoints` raw entry points + - `Unpacked` + - `Types` Unpacked futhark types, useful for constructing or deconstructing values + - `Native` + - `Types` Native type equivalents for (almost all) futhark types +#### Code example +Given the futhark file +```futhark +type someopaque = (f32, i64) + +entry foo (input:f32) : someopaque = (input, i64.f32 input) + +entry bar (input:someopaque) : []f32 = replicate (input.1) (input.0) +``` + +the generated library can be used like + +```haskell +module FutharkUsageExample where +import Mylib + +-- `foobar` composes `foo` and `bar`, +-- and converts the output array to a haskell native array +foobar :: Monad m => F32 -> m (Array F32) +foobar input = runFutT $ do + foores <- foo input + barres <- bar foores + fromFuthark barres + +-- `foobar'` does the same thing as `foobar` +-- but also immediately finalizes the intermediate results +foobar' :: MonadIO m => F32 -> m (Array F32) +foobar' input = runFutT $ do + foores <- foo input + barres <- bar foores + finalizeFO foores + native_barres <- fromFuthark barres + finalizeFO barres + pure native_barres +``` + +## Documentation +The base library contains basic documentation on the general classes and other core functions. `cabal haddock` can be used to obtain documentation specific to the generated library. + ## 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. +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. In particular, unnamed tuple structures are transparent, so the arguments and return values have the same structure as in the futhark type declaration. -### Context Generation - getContext :: [ContextOption] -> IO Context +### Primitive types +Primitive types are given aliases based on their name in futhark. +For example the haskell type `Float` is called `F32`. These aliases are used in all generated type signatures. -Available context options will depend on backend used. +### Tuples +Unnamed tuples are recursively unpacked in all function arguments and return values in the wrapped interface, and as such are simply tuples in Haskell too. This adds a little bit of overhead at each use but can be convenient when values need to be composed or when multiple return values are desired. If unpacking is undesired, simply make a type synonym in futhark. +### Opaques +Opaque values are values such as records, sums, nonprimitive arrays, and any type with an alias in the futhark file with the entry points. Unnamed types are given a name by parsing and reformatting the futhark type to a format allowed in Haskell. Since these names often end up fairly long and a little cryptic, it is recommended to name the types that are intended to be used. + +#### Value composition and decomposition +For opaque types instances of + +```haskell +class (FutharkObject fo) => FutharkComposite fo where + type Unpacked fo :: Type -> Type + pack :: (Monad m) => Unpacked fo c -> FutT c m (fo c) + unpack :: (Monad m) => fo c -> FutT c m (Unpacked fo c) +``` + +can be used to compose and decompose values with their `Unpacked` type as an intermediate. + +#### Haskell-native Types +In order to facilitate input and output, it is convenient to have a Haskell-native representation of the types used in the Futhark program. These are defined in the `Native.Types` submodule. + +Unnamed types are give a name based on the futhark type, and for arrays this is just a type synonym for the native array type of the element. +Named types retain their futhark name (but capitalized), and in the case of arrays this is a `newtype` around the native array type of the element. + +All types are instances of the `Element` class provided by `futhark-base` which defines array types for them and allows the use of generic array functions like `map`, `tabulate`, etc, to be used. + +#### Conversion +For conversion between Futhark values and Haskell native values, instances of + +```haskell +class Convertible fo where + Native fo + toFuthark :: Monad m => Native fo -> FutT c m (fo c) + fromFuthark :: Monad m => fo c -> FutT c m (Native fo) +``` + +are defined. Currently instances should exist for all futhark types except those containing arrays of sum types. Note that this does not mean that all Native values can be converted to Futhark values, as only those used by the entrypoints will be defined on the futhark side. Additionally care should be taken when converting nested arrays to Futhark values, as the native array type currently does not enforce regular arrays. + + +### Context Options +These options can be used change how the context operates. For more information see the [C-API documentation](https://futhark.readthedocs.io/en/stable/c-api.html). +#### All backends + - `TuningParameters [(String, CSize)]` + - `CacheFile String` Sets a cachefile for the context. Highly recommended to reduce startup times. + - `Debug Int` + - `Log Int` + - `Profile Int` +#### All GPU backends + - `Device String` + - `DefaultThreadBlockSize Int` + - `DefaultGridSize Int` + - `DefaultTileSize` +#### OpenCL + - `Platform String` + - `BuildOptions [String]` +#### Cuda + - `NvrtcOptions [String]` +#### Multicore + - `NumThreads Int` + + ### The Fut monad To make the wrappers safe, and reduce clutter from explicitly passing around the context, the `Fut` monad is introduced. The `Fut` monad is an environment monad that implicitly passes the context around as necessary. Like the `ST` monad, the `Fut` monad is parameterised by a rigid type variable to prevent references to the context from escaping the monad. To run computations, the function +``` +mkContext :: [ContextOption] -> IO (Context, [String]) +``` +to create a context, and then run the monad with - runFutIn :: Context -> (forall c. Fut c a) -> a +```haskell +runFutIn :: Context -> (forall c. Fut c a) -> a +``` -is used. Additionally +Additionally - runFutWith :: [ContextOption] -> (forall c. Fut c a) -> a - runFut :: (forall c. Fut c a) -> a +```haskell +runFutWith :: [ContextOption] -> (forall c. Fut c a) -> a +runFut :: (forall c. Fut c a) -> a +``` are defined for convienience for cases where the context doesn't need to be reused. ### The FutT transformer For more flexibility, the FutT monad transformer can be used. For convenience the type synonyms - type Fut c = FutT c Identity - type FutIO c = FutT c IO +```haskell +type Fut c = FutT c Identity +type FutIO c = FutT c IO +``` -are defined, but entry-points are in the general `Monad m => FutT c m`. +are defined, but entry-points and most other functions are in the polymorphic `Monad m => FutT c m`. +Actually these are just specialized versions of the more general transformer defined in the `Futhask` base library. + To run the transformer - - runFutTIn :: Context -> (forall c. FutT c m a) -> m a - runFutTWith :: [ContextOption] -> (forall c. FutT c m a) -> m a - runFutT :: (forall c. FutT c m a) -> m a +```haskell +runFutTIn :: Context -> (forall c. FutT c m a) -> m a +runFutTWith :: [ContextOption] -> (forall c. FutT c m a) -> m a +runFutT :: (forall c. FutT c m a) -> m a +``` + For lifting - mapFutT :: (m a -> n b) -> FutT c m a -> FutT c n b - map2FutT :: (m a -> n b -> k c) -> FutT c' m a -> FutT c' n b -> FutT c' k c - pureFut :: Monad m => Fut c a -> FutT c m a - unsafeFromFutIO :: FutIO c a -> Fut c a +```haskell +mapFutT :: (m a -> n b) -> FutT c m a -> FutT c n b +map2FutT :: (m a -> n b -> k c) -> FutT c' m a -> FutT c' n b -> FutT c' k c +pureFut :: Monad m => Fut c a -> FutT c m a +unsafeFromFutIO :: FutIO c a -> FutT c m a +``` #### Running transformer stacks When using `FutT c` with other transformers in a stack the type of the function running the monad may need to be defined explicitly. In the same way as `runFutT`, these signatures require an explicit `forall` to force `c` to be fully polymorphic. - runMyMonad :: (forall c. MyMonad c a) -> a +```haskell +runMyMonad :: (forall c. MyMonad c a) -> a +``` This requires the `RankNTypes` extension. -### Input and Output -For conversion between Futhark values and Haskell values, two classes are defined. - - class Input fo ho where - toFuthark :: Monad m => ho -> FutT c m (fo c) - - class Output fo ho where - fromFuthark :: Monad m => fo c -> FutT c m 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. - ### Memory management All of the wrapped values have finalizers, and should *eventually* be garbage collected. However, GHCs GC does not know how much memory the context is using, and so collection will not always be triggered frequently enough. This is primarily an issue when the program iterates on Futhark values, without any Haskell-side allocations. One way to deal with this is to manually manage the memory using - finalizeFO :: (MonadIO m, FutharkObject wrapped raw) => wrapped c -> FutT c m () +```haskell +finalizeFO :: (MonadIO m, FutharkObject fo) => fo c -> FutT c m () +``` As with any manual memory management, the programmer is responsible for ensuring that the finalized value will not be used afterwards. For cases where the object is used in more than one thread without synchronisation, - addReferenceFO :: (MonadIO m, FutharkObject wrapped raw) => wrapped c -> FutT c m () +```haskell +addReferenceFO :: (MonadIO m, FutharkObject fo) => fo c -> FutT c m () +``` can be used. `addReferenceFO` increments the reference counter of the object and `finalizeFO` will just decrement this counter until it's `0`. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,46 +1,123 @@ +{-# LANGUAGE OverloadedStrings, MultilineStrings #-} + module Main where + import System.IO import Data.Maybe +import Data.Text (Text) +import Data.Version +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString as B +import Text.ParserCombinators.ReadP as P 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 +import qualified Futhark.Manifest as FM +import qualified CodeGen as M +import qualified CabalGen as CG +import Context +import Monad 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 - "multicore" -> return Multicore - _ -> error $ "unknown backend: " ++ backendS ++ "\n available backends: c, opencl, cuda, multicore" - 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 "Fut", futHeader, futBody) - , (Just "Wrap", wrapHeader, wrapBody) - , (Just "Utils", utilsHeader, utilsBody) - , (Nothing, exportsHeader, "") ] + args <- getArgs + if length args == 5 + then do + libname <- pure (args !! 0) + libver <- pure (args !! 1) + cfile <- pure (args !! 2) + mfile <- pure (args !! 3) + dest <- pure (args !! 4) + manifest <- M.readManifest mfile + makelibrary (T.pack libname) (T.pack libver) (dest <> "/") cfile manifest + else M.putText + """ + Invalid number of arguments - futhask takes exactly 5 arguments: + \tLIBNAME - name of library to be generated + \tLIBVER - version of library to be generated + \tPROGRAM.c - C file generated by `futhark backend PROGRAM.fut --library` + \tPROGRAM.json - manifest file generated by `futhark backend PROGRAM.fut --library` + \tDEST - location of the generated library + """ + +makelibrary name libver pacdir program manifest = do + checkManifestVersion + backend <- pure $ case FM.manifestBackend manifest of + "c" -> C + "multicore" -> Multicore + "opencl" -> OpenCL + "cuda" -> Cuda + "hip" -> Hip + + createDirectoryIfMissing False pacdir + createDirectoryIfMissing False srcdir + createDirectoryIfMissing False libdir + createDirectoryIfMissing False rawdir + createDirectoryIfMissing False natdir + createDirectoryIfMissing False unpdir + copyFile program (pacdir <> "/src.c") + T.writeFile (pacdir <> T.unpack name <> ".cabal") + (CG.cabalFile futhaskVersion futhaskBaseVersion name libname libver backend) + T.writeFile (srcdir <> T.unpack libname <> ".hs") $ exports + T.writeFile (rawdir <> "Context.hs") $ rawContext + T.writeFile (rawdir <> "Types.hs") $ rawTypes + T.writeFile (rawdir <> "TypeDec.hs") $ rawTypeDec + T.writeFile (rawdir <> "TypeOps.hs") $ rawTypeOps + T.writeFile (rawdir <> "EntryPoints.hs") $ rawEntryPoints + T.writeFile (libdir <> "Raw.hs") $ rawExports + T.writeFile (libdir <> "Context.hs") $ context + T.writeFile (libdir <> "Monad.hs") $ monad + T.writeFile (libdir <> "Types.hs") $ types + T.writeFile (libdir <> "TypeDec.hs") $ typeDec + T.writeFile (libdir <> "TypeOps.hs") $ typeOps + T.writeFile (libdir <> "EntryPoints.hs") $ entryPoints + T.writeFile (libdir <> "Conversion.hs") $ conversion + T.writeFile (natdir <> "Types.hs") $ nativeTypes + T.writeFile (unpdir <> "Types.hs") $ unpackedTypes + where + futhaskVersion = "1.0.0.0" + futhaskBaseVersion = "0.1.0.0" + --name = "testlib" + --libver = "0.1" + --pacdir = "../testlibrary/" + --program = "test.c" + --manifestFile = "test.json" + libname = M.capitalize name + srcdir = pacdir <> "src/" + libdir = srcdir <> T.unpack libname <> "/" + rawdir = libdir <> "Raw/" + natdir = libdir <> "Native/" + unpdir = libdir <> "Unpacked/" + readVersion = fst . head . P.readP_to_S parseVersion . T.unpack + manifestVersionLowerBound = readVersion "0.27" + manifestVersionUpperBound = readVersion "1.0" + checkManifestVersion = + let version = readVersion (FM.manifestVersion manifest) + in if version < manifestVersionLowerBound + then error ("Manifest version " <> show version <> " is too old. Use newer futhark compiler.") + else if version > manifestVersionUpperBound + then putStrLn ("WARNING: Manifest version " <> show version <> " is newer than what has been tested for this version of Futhask.") + else pure () + exports = exportsHeader libname + rawContext = rawContextHeader libname <> rawContextDec manifest + rawTypes = rawTypesHeader libname + rawTypeDec = rawTypeDecHeader libname <> M.rawTypeDecs manifest + rawTypeOps = rawTypeOpsHeader libname <> M.rawTypeOpss manifest + rawEntryPoints = rawEntryPointsHeader libname <> M.rawEntryCalls manifest + rawExports = rawHeader libname + nativeTypes = nativeTypesHeader libname <> M.nativeTypeDecs manifest + unpackedTypes = unpackedTypesHeader libname <> M.unpackedTypeDecs manifest + context = contextHeader libname <> wrappedContextDec manifest + monad = monadHeader libname <> monadBody manifest + types = typesHeader libname + typeDec = typeDecHeader libname <> M.wrappedTypeDecs manifest + typeOps = typeOpsHeader libname <> M.wrappedTypeOpss manifest + entryPoints = entryPointsHeader libname <> M.wrappedEntryCalls manifest + conversion = conversionHeader libname <> M.conversionDecs manifest diff --git a/futhask.cabal b/futhask.cabal --- a/futhask.cabal +++ b/futhask.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: futhask -version: 0.2.0 +version: 1.0.0 synopsis: Generate Haskell wrappers for Futhark libraries description: Please see the README on GitLab at category: FFI Tools @@ -22,18 +22,24 @@ library exposed-modules: Backends - CodeBodies - Conversion Headers + CodeGen + Context + Monad + CabalGen other-modules: Paths_futhask hs-source-dirs: src build-depends: - base >=4.7 && <4.15 + base >=4.7 && <5 , directory >=1.3.3 && <1.4 , raw-strings-qq >=1.1 && <1.2 , split >=0.2.3 && <0.3 + , futhark-manifest ==1.9.0.0 + , text >=2.0.1 && < 3 + , bytestring >=0.10 && <1 + , containers >=0.6 && <1 default-language: Haskell2010 executable futhask @@ -49,4 +55,8 @@ , futhask , raw-strings-qq , split + , futhark-manifest >=1.7 + , text >=2.0.1 + , bytestring >=0.10 + , containers >=0.6 default-language: Haskell2010 diff --git a/src/Backends.hs b/src/Backends.hs --- a/src/Backends.hs +++ b/src/Backends.hs @@ -1,3 +1,3 @@ module Backends where -data Backend = C | OpenCL | Cuda | Multicore +data Backend = C | OpenCL | Cuda | Hip | Multicore diff --git a/src/CabalGen.hs b/src/CabalGen.hs new file mode 100644 --- /dev/null +++ b/src/CabalGen.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module CabalGen where +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as T +import Backends + +indent = T.unlines . map (" " <>) . T.lines +formatItems items = T.unlines $ map (\(a, b) -> a <> ": " <> b) items +formatSection title items = title <> "\n" <> (indent $ formatItems items) +formatList items = "\n" <> indent (T.unlines items) + +cabalFile futhaskVersion futhaskBaseVersion name libname version backend = cabalVersion <> comment <> header <> library + where + cabalVersion = "cabal-version: 3.0\n" + comment = "--This file was generated by futhask version " <> futhaskVersion <> "\n" + header = formatItems[ ("name", name), ("version", version) ] + library = formatSection "library" + [ ("build-depends", formatList depends) + , ("hs-source-dirs", "src") + , ("c-sources", "src.c" ) + , ("include-dirs", formatList includeDirs) + , ("extra-lib-dirs", formatList libDirs) + , ("extra-libraries", formatList libs) + , ("exposed-modules", formatList modules) + , ("default-language", language) ] + language = "GHC2024"--"Haskell2010" + modules = libname : map ((libname <> ".") <>) + [ "Raw" + , "Raw.Context" + , "Raw.Types" + , "Raw.TypeDec" + , "Raw.TypeOps" + , "Raw.EntryPoints" + , "Context" + , "Monad" + , "Types" + , "TypeDec" + , "TypeOps" + , "EntryPoints" + , "Conversion" + , "Unpacked.Types" + , "Native.Types" ] + + depends = + [ "base >= 4 && < 5," + , "futhask-base == " <> futhaskBaseVersion ] + includeDirs = case backend of + OpenCL -> [""] + Cuda -> ["/usr/local/cuda/include"] + Hip -> ["/opt/rocm/include"] + _ -> [] + libDirs = case backend of + OpenCL -> [""] + Cuda -> ["/usr/local/cuda/lib64"] + Hip -> ["/opt/rocm/lib"] + _ -> [""] + libs = case backend of + OpenCL -> ["OpenCL"] + Cuda -> ["cuda", "cudart", "nvrtc"] + Hip -> ["hiprtc", "amdhip64"] + _ -> [] + + diff --git a/src/CodeBodies.hs b/src/CodeBodies.hs deleted file mode 100644 --- a/src/CodeBodies.hs +++ /dev/null @@ -1,560 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - - -module CodeBodies where -import Text.RawString.QQ -import Backends - -typeClassesBody = [r| -class FutharkObject wrapped raw | wrapped -> raw, raw -> wrapped where - wrapFO :: MVar Int -> ForeignPtr raw -> wrapped c - freeFO :: Ptr Raw.Futhark_context -> Ptr raw -> IO Int - fromFO :: wrapped c -> (MVar Int, ForeignPtr raw) - -withFO :: FutharkObject wrapped raw => wrapped c -> (Ptr raw -> IO b) -> IO b -withFO = withForeignPtr . snd . fromFO - -addReferenceFO :: (MonadIO m, FutharkObject wrapped raw) => wrapped c -> FutT c m () -addReferenceFO fo = lift . liftIO $ - let (referenceCounter, _) = fromFO fo - in modifyMVar_ referenceCounter (\r -> pure (r+1)) - -finalizeFO :: (MonadIO m, FutharkObject wrapped raw) => wrapped c -> FutT c m () -finalizeFO fo = lift . liftIO $ - let (referenceCounter, pointer) = fromFO fo - in modifyMVar_ referenceCounter (\r - -> if r > 0 - then pure (r-1) - else finalizeForeignPtr pointer >> pure 0) - - -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 :: Monad m => ho -> FutT c m (fo c) - -class Output fo ho where - fromFuthark :: Monad m => fo c -> FutT c m ho - -|] - -configBody C = [r| -data ContextOption - = Debug Int - | Log Int - | Cache String - -setOption config option = case option of - (Debug flag) -> Raw.context_config_set_debugging config flag - (Log flag) -> Raw.context_config_set_logging config flag - (Cache s) -> withCString s $ Raw.context_config_set_cache_file config -|] - -configBody Multicore = [r| -data ContextOption - = Debug Int - | Log Int - | Cache String - | NumThreads 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 - (NumThreads n) -> Raw.context_config_set_num_threads config n - (Cache s) -> withCString s $ Raw.context_config_set_cache_file config -|] - -configBody OpenCL = [r| -data ContextOption - = BuildOptions [String] - | Debug Int - | Profile Int - | Log Int - | Cache String - | Device String - | Platform String - | LoadProgram String - | DumpProgram String - | LoadBinary String - | DumpBinary String - | DefaultGroupSize Int - | DefaultGroupNum Int - | DefaultTileSize Int - | DefaultRegTileSize 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 - (Cache s) -> withCString s $ Raw.context_config_set_cache_file config - (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 - (DumpProgram s) -> withCString s $ Raw.context_config_dump_program_to 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 - (DefaultRegTileSize s) -> Raw.context_config_set_default_reg_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 - | Cache String - | Device String - | LoadProgram String - | DumpProgram String - | LoadPtx String - | DumpPtx String - | DefaultGroupSize Int - | DefaultGroupNum Int - | DefaultTileSize Int - | DefaultRegTileSize 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 - (Cache s) -> withCString s $ Raw.context_config_set_cache_file config - (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 - (DefaultRegTileSize s) -> Raw.context_config_set_default_reg_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 - childCount <- newMVar 0 - fmap (Context childCount) - $ FC.newForeignPtr context - $ (forkIO $ freeContext childCount config context) - >> return () - -freeContext childCount config context - = readMVar childCount >>= \n - -> if n == 0 - then do Raw.context_free context - Raw.context_config_free config - else yield >> freeContext childCount config context - -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 - case code of - 0 -> success - 1 -> generalError - 2 -> programError - 3 -> outOfMemoryError - _ -> unknownError - where - attempt = inContext context f - success = return () - failure = getError context - generalError = failure - programError = failure - outOfMemoryError = do - clearError context - performGC - code' <- attempt - if code' == 0 - then success - else failure - unknownError = failure - -|] - - -futBody = [r| - -newtype FutT c m a = FutT (Context -> m a) - -instance MonadTrans (FutT c) where - lift a = FutT (\_ -> a) - {-# INLINEABLE lift #-} - -instance Functor m => Functor (FutT c m) where - fmap f (FutT a) = FutT (fmap f.a) - {-# INLINEABLE fmap #-} - -instance Applicative m => Applicative (FutT c m) where - pure a = FutT (\_ -> pure a) - (<*>) (FutT a) (FutT b) = FutT (\c -> a c <*> b c) - {-# INLINEABLE pure #-} - {-# INLINEABLE (<*>) #-} - -instance Monad m => Monad (FutT c m) where - (>>=) (FutT a) f = FutT (\c -> a c >>= (\(FutT b) -> b c) . f) - {-# INLINEABLE (>>=) #-} - -instance (MonadBase b m) => MonadBase b (FutT c m) where - liftBase = liftBaseDefault - {-# INLINEABLE liftBase #-} - -instance MonadTransControl (FutT c) where - type StT (FutT c) a = a - liftWith a = FutT (\c -> a (\(FutT a') -> a' c)) - restoreT = lift - {-# INLINEABLE liftWith #-} - {-# INLINEABLE restoreT #-} - -instance MonadBaseControl b m => MonadBaseControl b (FutT c m) where - type StM (FutT c m) a = ComposeSt (FutT c) m a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM - {-# INLINEABLE liftBaseWith #-} - {-# INLINEABLE restoreM #-} - - -type Fut c = FutT c Identity -type FutIO c = FutT c IO - -mapFutT :: (m a -> n b) -> FutT c m a -> FutT c n b -mapFutT f (FutT a) = FutT (f.a) -map2FutT :: (m a -> n b -> k c) -> FutT c' m a -> FutT c' n b -> FutT c' k c -map2FutT f (FutT a) (FutT b) = FutT (\c -> f (a c) (b c)) - - -runFutTIn :: Context -> (forall c. FutT c m a) -> m a -runFutTIn context (FutT a) = a context - -runFutTWith :: [ContextOption] -> (forall c. FutT c m a) -> m a -runFutTWith options a - = unsafePerformIO - $ getContext options >>= \c -> return $ runFutTIn c a -runFutT = runFutTWith [] - -runFutIn :: Context -> (forall c. Fut c a) -> a -runFutIn context a = runIdentity $ runFutTIn context $ a - -runFutWith :: [ContextOption] -> (forall c. Fut c a) -> a -runFutWith options a = runIdentity $ runFutTWith options a -runFut = runFutWith [] - -pureFut :: (Monad m) => Fut c a -> FutT c m a -pureFut (FutT a) = FutT (pure . runIdentity . a) - -unsafeFromFutIO :: FutIO c a -> Fut c a -unsafeFromFutIO (FutT a) = FutT (Identity . unsafePerformIO . a) - -unsafeLiftFromIO :: Monad m => (Context -> IO a) -> FutT c m a -unsafeLiftFromIO a = FutT (pure . unsafePerformIO . a) - -|] - - -wrapBody = [r| - -wrapIn :: FutharkObject wrapped raw => Context -> Ptr raw -> IO (wrapped c) -wrapIn context@(Context childCount pointer) rawObject = do - modifyMVar_ childCount (\cc -> return $! (cc+1)) - referenceCounter <- newMVar 0 - pointer <- FC.newForeignPtr rawObject freeCall - pure $! wrapFO referenceCounter pointer - where freeCall = (inContextWithError context $ \c -> freeFO c rawObject) - >> modifyMVar_ childCount (\cc -> return $! (cc-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 - shape <- shapeFA c aP - pointer <- mallocForeignPtrArray $ M.totalElem shape - withForeignPtr pointer $ valuesFA c aP - syncContext context - 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') ---} - - diff --git a/src/CodeGen.hs b/src/CodeGen.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen.hs @@ -0,0 +1,1301 @@ +{-# LANGUAGE OverloadedStrings #-} +--{-# LANGUAGE PatternSynonyms #-} +--{-# LANGUAGE ViewPatterns #-} + +module CodeGen where + +import Futhark.Manifest +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString as B +import qualified Data.Char as C +import qualified Data.Map.Strict as M +import Text.ParserCombinators.ReadP as P +import Debug.Trace + +readManifest :: FilePath -> IO Manifest +readManifest path = B.readFile path >>= \bs -> case (manifestFromJSON $ T.decodeUtf8 bs) of + Just manifest -> return manifest + Nothing -> error "Invalid manifest file" + +writeText path = B.writeFile path . T.encodeUtf8 +putText = T.putStrLn + + +--Futhark to Haskell +futhaskTypeMap :: M.Map Text Text +futhaskTypeMap = M.fromList + [ ("f16", "F16") + , ("f32", "F32") + , ("f64", "F64") + , ("bool", "CBool") + , ("i8" , "I8") + , ("i16", "I16") + , ("i32", "I32") + , ("i64", "I64") + , ("u8" , "U8") + , ("u16", "U16") + , ("u32", "U32") + , ("u64", "U64") ] + +primitive = + [ "f16" + , "f32" + , "f64" + , "bool" + , "i8" + , "i16" + , "i32" + , "i64" + , "u8" + , "u16" + , "u32" + , "u64" ] + +isPrimitive a = elem a primitive +isBool a = a == "bool" + +haskellElemType :: TypeName -> Text +haskellElemType ft = case M.lookup ft futhaskTypeMap of + Just ht -> ht + Nothing -> error (T.unpack ft <> " is not a valid element type") + +haskellType :: TypeName -> Text +haskellType ft = case M.lookup ft futhaskTypeMap of + Just ht -> ht + Nothing -> reformatTypeName ft + +rawHaskellType :: TypeName -> Text +rawHaskellType ft = case M.lookup ft futhaskTypeMap of + Just ht -> ht + Nothing -> pointer (raw $ reformatTypeName ft) + +rawOutputType output = if M.member (outputType output) futhaskTypeMap + then pointer (haskellType $ outputType output) + else pointer $ pointer (raw $ haskellType (outputType output)) + +rawInputType input = if M.member (inputType input) futhaskTypeMap + then (haskellType $ inputType input) + else pointer (raw $ haskellType (inputType input)) +--C to Haskell +chaskTypeMap = M.fromList + [ ("int", "Int") + , ("float", "Float") + , ("double", "Double") + , ("char", "CChar") + , ("unsigned char", "CUChar") + , ("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") + , ("FILE", "CFile") + , ("cl_mem", "CLMem") + , ("cl_command_queue", "CLCommandQueue") + , ("CUdeviceptr", "DevicePtr ()") ] + + +csize = "CSize" +cbyte = "CChar" + +capitalize t = case T.uncons t of + Nothing -> t + Just (i, r) -> T.cons (C.toUpper i) r + +decapitalize t = case T.uncons t of + Nothing -> t + Just (i, r) -> T.cons (C.toLower i) r + +-- bad conversion, needs improvement +markdown2haddock t = T.replace "`" "@" $ t +comment t = case T.lines (markdown2haddock t) of + [] -> "" + (l:ls) -> T.unlines $ map ("-- " <>) $ ("|" <> l : ls) + +hcomment t = "-- *" <> t <> "\n" +codecomment t = "-- | @" <> t <> "@\n" +indent :: Text -> Text +indent = T.unlines . (map (" " <>)) . T.lines + +commaSep = T.intercalate ", " +arrowSep = T.intercalate " -> " +wrap t = "(" <> t <> ")" + +tuple :: [Text] -> Text +tuple elements = wrap (commaSep elements) +strictTuple = tuple . map ("!"<>) + + +wrapIfNotOneWord t = if length (T.words t) == 1 then t else wrap t +wrapIfNotTupleOrPrimitive t s = if isPrimitive t then s else if isTuple t then s else wrap s +wrapIfNotWrappedOrSingleton s = if (T.head s == '(' && T.last s == ')') || length (T.words s) == 1 then s else wrap s + +raw t = "Raw." <> t +wrapped t = "Wrapped." <> t +(<->) a b = a <> "_" <> b +(<~>) a b = a <> " " <> b +(<=>) a b = a <> " = " <> b +() a b = a <> "\n" <> b +() a b = a <> "\n " <> b + + +pointer t = "Ptr " <> wrapIfNotOneWord t +void = "()" + +unpacked t = "{-# UNPACK #-}!(" <> t <> ")" + +data CompositeType = SimpleType Text | ArrayType Int CompositeType | TupleType [CompositeType] | RecordType [(String, CompositeType)] | SumType [(String, [CompositeType])] deriving Show +formatCompositeType :: CompositeType -> Text +formatCompositeType (SimpleType name) = capitalize name +formatCompositeType (ArrayType rank elem) = "Arr" <> T.pack (show rank) <-> formatCompositeType elem +formatCompositeType (TupleType fields) = if length fields == 0 then "Unit" else + "Tup" <> T.pack (show (length fields)) <-> T.intercalate "_" (map formatCompositeType fields) +formatCompositeType (RecordType fields) = + "Rec" <> T.pack (show (length fields)) <-> T.intercalate "_" (map (\(n, t) -> T.pack n <-> formatCompositeType t) fields) +formatCompositeType (SumType variants) = "Sum" <> T.pack (show (length variants)) <-> T.intercalate "_" (map (\(c, ps) -> T.pack c <-> T.intercalate "_" (map formatCompositeType ps)) variants) + +haskellEquivType :: CompositeType -> Text +haskellEquivType (SimpleType t) = haskellType t +haskellEquivType (ArrayType rank elem) = if rank > 0 then "Array " <> wrapIfNotWrappedOrSingleton (haskellEquivType (ArrayType (rank-1) elem)) else haskellEquivType elem +haskellEquivType (TupleType fields) = tuple (map haskellEquivType fields) +haskellEquivType (RecordType fields) = formatCompositeType(RecordType fields) +haskellEquivType (SumType variants) = formatCompositeType (SumType variants) + + +readDigit = fmap C.digitToInt (P.satisfy C.isDigit) +readTuple readElem = do + P.char '(' + elems <- P.sepBy readElem (skipSpaces >> P.char ',' >> skipSpaces) + P.char ')' + pure elems +readRecord readFieldType = do + P.char '{' + fields <- P.sepBy readField (skipSpaces >> P.char ',' >> skipSpaces) + P.char '}' + pure fields + where + readField = do + skipSpaces + n <- P.munch1 (/= ':') + skipSpaces + P.char ':' + skipSpaces + t <- readFieldType + pure (n, t) + + +readCompositeType :: P.ReadP CompositeType +readCompositeType = do + skipSpaces + get >>= \c -> case c of + '(' -> P.sepBy readCompositeType (P.char ',' >> skipSpaces) >>= \m -> char ')' >> pure (if length m == 1 then head m else TupleType m) + '{' -> P.sepBy + (P.munch (/=':') >>= \n -> char ':' >> P.skipSpaces >> readCompositeType >>= \t -> pure (n, t)) + (P.char ',' >> P.skipSpaces) + >>= \m -> char '}' >> pure (RecordType m) + '[' -> P.munch (\c -> elem c ("[]" :: String)) >>= \p -> readCompositeType >>= \elem -> pure (ArrayType (div (length p + 1) 2) elem) + '#' -> P.sepBy + (P.munch (/=' ') >>= \cons -> P.sepBy readCompositeType (P.char ' ') >>= \payloads -> pure (cons, payloads)) + (P.string " | #") + >>= \cps -> pure (SumType cps) + _ -> P.munch (\c -> not $ elem c (" ()[]{},#|"::String)) >>= \cs -> pure (SimpleType (T.pack (c:cs))) + where + char c = P.char c >>= \_ -> pure () + + +parseCompositeType :: TypeName -> CompositeType +parseCompositeType n = case (P.readP_to_S (readCompositeType >>= \t -> P.eof >> pure t) $ T.unpack n) of + [] -> error (T.unpack ("unable to parse type: " <> n)) + (a:_) -> fst a +parseCompositeType' = fst . head . P.readP_to_S readCompositeType + +reformatTypeName = formatCompositeType . parseCompositeType +reformatTypeName' = T.unpack . formatCompositeType . parseCompositeType . T.pack + +nativeType :: TypeName -> Text +nativeType = haskellEquivType . parseCompositeType +isTuple t = case parseCompositeType t of + (TupleType _) -> True + _ -> False + +type Constraint = Text + +assignment :: Text -> Text -> Text +assignment a b = a <> " = " <> b <> "\n" + +sumFormat :: TypeName -> [(Text, [TypeName])] -> Text +sumFormat name constructors + = "data " <> name <> "\n" + <> indent ("= " <> T.intercalate "\n| " (map (\(c, as) -> T.unwords (c:as)) constructors) <> "\n") + <> "\n" +sumFormat' :: TypeName -> [(Text, [TypeName])] -> Text +sumFormat' name constructors + = "data " <> name <> "\n" + <> indent ("= " <> T.intercalate "\n| " (map (\(c, as) -> T.unwords (c:as)) constructors) <> "\n") + <> " deriving Show\n" + <> "\n" + + + +recFormat :: TypeName -> [(Text, TypeName)] -> Text +recFormat name fields + = "data " <> name <> " = " <> name <> "\n" + <> indent ("{ " <> T.intercalate "\n, " (map (\(f, t) -> f <> " :: " <> t) fields) <> " }\n") + <> "\n" +recFormat' :: TypeName -> [(Text, TypeName)] -> Text +recFormat' name fields + = "data " <> name <> " = " <> name <> "\n" + <> indent ("{ " <> T.intercalate "\n, " (map (\(f, t) -> f <> " :: " <> t) fields) <> " } deriving Show\n") + <> "\n" +qrecFormat :: TypeName -> [(Text, TypeName)] -> Text +qrecFormat name fields + = "data " <> name <> " c = " <> name <> "\n" + <> indent ("{ " <> T.intercalate "\n, " (map (\(f, t) -> f <> " :: " <> t) fields) <> " }\n") + <> "\n" + +typeFormat :: TypeName -> TypeName -> Text +typeFormat nt ot + = "type " <> nt <> " = " <> ot <> "\n" +qtypeFormat :: TypeName -> TypeName -> Text +qtypeFormat nt ot + = "type " <> nt <> " c = " <> ot <> "\n" +newtypeFormat :: TypeName -> TypeName -> Text +newtypeFormat nt ot + = "newtype " <> nt <> " = " <> nt <~> ot <> "\n" +newtypeFormat' :: TypeName -> TypeName -> Text +newtypeFormat' nt ot + = "newtype " <> nt <> " = " <> nt <~> ot <~> "deriving Show\n" +qnewtypeFormat :: TypeName -> TypeName -> Text +qnewtypeFormat nt ot + = "newtype " <> nt <> " c = " <> nt <~> ot <> "\n" + +caseFormat :: Text -> [(Text, Text)] -> Text +caseFormat expression cases + = "case " <> expression <> " of\n" + <> indent (mconcat (map (\(pattern, result) -> pattern <~> "->" <~> result <> "\n") cases)) + +functionFormat :: Text -> TypeName -> [(Text, TypeName, [Constraint])] -> Text -> Text +functionFormat name outputType arguments body + = name + <> " :: " + <> tuple (concatMap (\(_, t, cs) -> (map (\c -> c <~> t) cs) ) arguments) + <> " => " + <> arrowSep ( (map (\(_, t, _) -> t) arguments) <> [outputType]) + <> "\n" + <> name + <> mconcat (map (\(n, _, _) -> " " <> n) arguments) + <> " = \n" + <> indent body + <> "\n" + + +classFormat :: Text -> [(TypeName, [Constraint])] -> [([Text], Text)] -> [(Text, TypeName, [TypeName])] -> Text +classFormat name parameters dependencies methods + = "class " + <> tuple (concatMap (\(t, cs) -> (map (\c -> c <> " " <> t) cs) ) parameters) + <> " => " + <> name + <> " " + <> T.unwords (map fst parameters) + <> if dependencies == [] + then "" + else " | " <> commaSep (map (\(ts, t) -> T.unwords ts <> " -> " <> t) dependencies) + <> " where" + <> "\n" + <> indent (mconcat $ map (\(n,t,ats) -> n <> " :: " <> arrowSep (ats <> [t]) <> "\n") methods) + <> "\n" + +instanceFormat :: Text -> [(TypeName, [Constraint])] -> [Text] -> Text +instanceFormat className instanceTypes methods + = "instance " + <> className + <> " " + <> T.unwords (map fst instanceTypes) + <> " where" + <> "\n" + <> indent (mconcat methods) + <> "\n" + +cFFICall :: Text -> CFuncName -> [Text] -> Text -> Text +cFFICall name cfunc argTypes returnType + = "foreign import ccall unsafe \"" <> cfunc <> "\"" + <> "\n " + <> decapitalize name + <> "\n :: " + <> mconcat (map (<> "\n -> ") argTypes) + <> "IO " <> wrapIfNotOneWord returnType + <> "\n" + + +withCtxCall outformat fun inputTypes outputTypes = "" + <> mconcat (zipWith (\i t -> if isPrimitive t + then "" + else " -> withRawObject in" <> i <> " $ \\in" <> i <> "'\n") inputNums inputTypes) + <> mconcat (map (\i -> " -> alloca $ \\outptr" <> i <> "\n") outputNums) + <> " -> inContextWithError ctx (\\ctx'\n" + <> " -> " <> fun <> " ctx' " + <> T.unwords (map ("outptr" <>) outputNums) + <> " " + <> T.unwords (zipWith (\i t -> if isPrimitive t + then "in" <> i + else "in" <> i <> "'") inputNums inputTypes) <> ")\n" + <> " >> " + <> mconcat (zipWith (\i t -> "peek outptr" <> i <> " >>= wrap" <> (if isPrimitive t then "" else "FO") <~> "ctx >>= \\out" <> i <> "\n -> ") outputNums outputTypes) + <> "pure" <~> outformat (map ("out" <>) outputNums) <> "\n" + where + inputNums = zipWith (\i _ -> T.pack (show (i::Int))) [0..] inputTypes + outputNums = zipWith (\i _ -> T.pack (show (i::Int))) [0..] outputTypes +futCall fun inputTypes outputTypes = "unsafeLiftFromIO $ \\ctx\n" <> withCtxCall tuple fun inputTypes outputTypes +rawContextType :: Text +rawContextType = "C.Context" +contextPointer = pointer rawContextType + +rawEntryCall :: Text -> EntryPoint -> Text +rawEntryCall name entry = cFFICall name (entryPointCFun entry) argTypes "Int" + where + argTypes = contextPointer + : (rawOutputType $ entryPointOutput entry) + : (map rawInputType $ entryPointInputs entry) +packTuple manifest t = pack t + where + inContext f args = "inContextWithError ctx (\\ctx -> " <> f <> " ctx " <> T.unwords args <> ")" + outputInContext f args = "alloca (\\ptr -> " <> inContext f ("ptr":args) <> " >> peek ptr)" + subtypes t = case M.lookup t (manifestTypes manifest) of + Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops) + _ -> error "nontuple type" + subargs t = zipWith (\i _ -> "t" <> T.pack (show i)) [0..] (subtypes t) + pack t = let as = subargs t + in "(\\" <> tuple as <> "\n" + <> indent ( " -> " + <> mconcat (zipWith (\st a -> if isPrimitive st + then "" + else if isTuple st + then pack st <~> a <> " >>= \\" <> a <> "\n -> " + else "withRawObject " <> a <> " $ \\" <> a <> "\n -> ") + (subtypes t) as) + <> outputInContext ("Raw.new_" <> reformatTypeName t) as <> " >>= \\t\n -> " + <> mconcat (zipWith (\t a -> if isTuple t + then inContext ("Raw.free_" <> reformatTypeName t) [a] <> "\n >> " + else "") + (subtypes t) as) + <> "pure t) " ) +unpackTuple manifest t = unpack t + where + inContext f args = "inContextWithError ctx (\\ctx -> " <> f <> " ctx " <> T.unwords args <> ")" + outputInContext f args = "alloca (\\ptr -> " <> inContext f ("ptr":args) <> " >> peek ptr)" + subtypes t = case M.lookup t (manifestTypes manifest) of + Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops) + _ -> error "nontuple type" + subargs t = zipWith (\i _ -> "t" <> T.pack (show i)) [0..] (subtypes t) + unpack t = let as = subargs t + in "(\\t\n" + <> indent ( " -> " + <> mconcat (zipWith3 (\a st i -> outputInContext ("Raw.project" <-> reformatTypeName t <-> T.pack (show i)) ["t"] + <> (if isTuple st + then "\n >>= " <> unpack st + else (if isPrimitive st then "" else " >>= wrapFO ctx")) + <> " >>= \\" <> a <> "\n -> ") + as (subtypes t) [0..]) + <> inContext ("Raw.free" <-> reformatTypeName t) ["t"] <> "\n >> pure " <> tuple as <> ") " ) + +packTuple' manifest t = pack t + where + inContext f args = "C.inContextWithError ctx (\\ctx -> " <> f <> " ctx " <> T.unwords args <> ")" + outputInContext f args = "F.alloca (\\ptr -> " <> inContext f ("ptr":args) <> " >> F.peek ptr)" + subtypes t = case M.lookup t (manifestTypes manifest) of + Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops) + _ -> error "nontuple type" + subargs t = zipWith (\i _ -> "t" <> T.pack (show i)) [0..] (subtypes t) + pack t = let as = subargs t + in "(\\" <> tuple as <> "\n" + <> indent ( " -> " + <> mconcat (zipWith (\st a -> if isPrimitive st + then if isBool st + then "pure (F.fromBool " <> a <> ") >>= \\" <> a <> "\n -> " + else "" + else if isTuple st + then pack st <~> a <> " >>= \\" <> a <> "\n -> " + else "O.withRawObject " <> a <> " $ \\" <> a <> "\n -> ") + (subtypes t) as) + <> outputInContext ("Raw.new_" <> reformatTypeName t) as <> " >>= \\t\n -> " + <> mconcat (zipWith (\t a -> if isTuple t + then inContext ("Raw.free_" <> reformatTypeName t) [a] <> "\n >> " + else "") + (subtypes t) as) + <> "pure t) " ) +unpackTuple' manifest t = unpack t + where + inContext f args = "C.inContextWithError ctx (\\ctx -> " <> f <> " ctx " <> T.unwords args <> ")" + outputInContext f args = "F.alloca (\\ptr -> " <> inContext f ("ptr":args) <> " >> F.peek ptr)" + subtypes t = case M.lookup t (manifestTypes manifest) of + Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops) + _ -> error "nontuple type" + subargs t = zipWith (\i _ -> "t" <> T.pack (show i)) [0..] (subtypes t) + unpack t = let as = subargs t + in "(\\t\n" + <> indent ( " -> " + <> mconcat (zipWith3 (\a st i -> outputInContext ("Raw.project" <-> reformatTypeName t <-> T.pack (show i)) ["t"] + <> (if isTuple st + then "\n >>= " <> unpack st + else (if isPrimitive st then if isBool st then ">>= pure . F.toBool" else "" else " >>= O.wrapFO ctx")) + <> " >>= \\" <> a <> "\n -> ") + as (subtypes t) [0..]) + <> inContext ("Raw.free" <-> reformatTypeName t) ["t"] <> "\n >> pure " <> tuple as <> ") " ) + +wrappedEntryCall manifest name entry + = (doc <> typeDec <> "\n", pragma <> callDec <> "\n") + where + doc = comment $ "`" <> futtype <> "`" <> case entryPointDoc entry of + Nothing -> "" + Just d -> "\n\n" <> d + inputs = entryPointInputs entry + output = entryPointOutput entry + subtypes t = case M.lookup t (manifestTypes manifest) of + Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops) + _ -> error "nontuple type" + subargs t = zipWith (\i _ -> "t" <> T.pack (show i)) [0..] (subtypes t) + name' = decapitalize name + futtype = name + <~> T.unwords (map (\i -> "(" <> inputName i <> " : " <> (if inputUnique i then "*" else "") <> inputType i <> ")") inputs) + <> " : " <> outputType output + tuningDec = let ps = entryPointTuningParams entry in if length ps == 0 + then "" + else comment $ "tuning parameters:\n" <> mconcat (map (\t -> " - " <> t <> "\n") ps) + attributeDec = let as = entryPointAttrs entry in if length as == 0 + then "" + else comment $ "attributes:\n" <> mconcat (map (\t -> " - " <> t <> "\n") as) + typeDec = name' <> " :: " <> (if any inputUnique inputs then "MonadIO" else "Monad") <> " m\n => " + <> mconcat (map (\i -> typeDec' (inputType i) <> " -- ^" <> inputName i <> "\n -> " ) inputs) + <> "M.FutT c m " + <> (let ot = outputType output in if isTuple ot + then typeDec' ot + else wrapIfNotOneWord (typeDec' ot)) + <> "\n" + typeDec' t = if isTuple t + then tuple (map typeDec' (subtypes t)) + else reformatTypeName t <> (if isPrimitive t then "" else " c") + pragma = "{-# NOINLINE " <> name <> " #-}\n" + callDec = name' <~> T.unwords args <> " = M.unsafeLiftFromIO (\\ctx\n -> " + <> mconcat (zipWith prepareInput inputs args) + <> callRaw + <> processOutput + <> cleanup + <> "C.sync ctx >> pure res)" + <> if any inputUnique inputs + then " >>= \\res\n -> " <> freeuniqueinputs <> "pure res\n" + else "\n" + args = zipWith (\i _ -> "arg" <> T.pack (show i)) [0..] inputs + prepareInput i a = let t = inputType i in if isPrimitive t + then if isBool t + then "pure (F.fromBool " <> a <> ") >>= \\" <> a <> "\n -> " + else "" + else if isTuple t + then packTuple' manifest t <~> a <> " >>= \\" <> a <> "\n -> " + else "O.withRawObject" <~> a <~> "$ \\" <> a <> "\n -> " + + processOutput = let t = outputType output in if isPrimitive t + then if isBool t + then " >>= pure . F.toBool >>= \\res\n -> " + else " >>= \\res\n -> " + else if isTuple t + then "\n >>= " <> unpackTuple' manifest t <> " >>= \\res\n -> " + else "\n >>= O.wrapFO ctx >>= \\res\n -> " + inContext f args = "C.inContextWithError ctx (\\ctx -> " <> f <> " ctx " <> T.unwords args <> ")" + outputInContext f args = "F.alloca (\\ptr -> " <> inContext f ("ptr":args) <> " >> F.peek ptr)" + cleanup = mconcat (zipWith (\i a -> if isTuple (inputType i) + then inContext ("Raw.free_" <> reformatTypeName (inputType i)) [a] <> "\n >> " else "") inputs args) + freeuniqueinputs = mconcat (zipWith (\i a -> if inputUnique i + then finalizeValue a (inputType i) + else "" ) inputs args) + finalizeValue n t = if isPrimitive t + then "" + else if isTuple t + then + let as = subargs t + in "(\\" <> tuple as <> "\n" + <> indent ( " -> " + <> mconcat (zipWith finalizeValue as (subtypes t)) + <> "pure () ") + <> ") " <> n <> "\n >> " + else "O.finalizeFO " <> n <> "\n >> " + callRaw = outputInContext ("RawEntry." <> name) args + +rawTypeDec :: Text -> Type -> Text +rawTypeDec name _ = codecomment name <> "\n" <> "data" <~> reformatTypeName name <> "\n\n" + +wrappedTypeDec :: Text -> Type -> Text +wrappedTypeDec name _ = if isTuple name then "" else + let name' = reformatTypeName name + in codecomment name <> "\n" + <> "data " <> name' <> " c = " <> name' <~> unpacked "Futhask.ReferenceCounter" <~> unpacked ("F.ForeignPtr" <~> raw name') <> "\n" + <> "\n" +unpackedType manifest t = if isPrimitive t + then reformatTypeName t + else if isTuple t + then tuple (map (unpackedType manifest) (subtypes t)) + else "Packed." <> reformatTypeName t <~> "c" + where + subtypes t = case M.lookup t (manifestTypes manifest) of + Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops) + _ -> error "nontuple type" + +unpackedTypeDec manifest name (TypeOpaque ctype ops mExtraOps doc) = dec + where + dec = case mExtraOps of + Just (OpaqueSum ops) -> unpackedSumDec manifest name ops + Just (OpaqueRecord ops) -> unpackedRecordDec manifest name ops + Just (OpaqueRecordArray ops) -> unpackedRecordArrayDec manifest name ops + _ -> "" + +unpackedTypeDec manifest name _ = "" +unpackedSumDec manifest name ops = codecomment name <> sumFormat (reformatTypeName name <~> "c") (map variant $ sumVariants ops) + where + variant v = (reformatTypeName name <-> sumVariantName v, map (\p -> wrapIfNotTupleOrPrimitive p (unpackedType manifest p)) $ sumVariantPayload v) + + +unpackedRecordDec manifest name ops = if length fields == 0 then "" else if isTuple' + then if isTuple name + then "" + else codecomment name <> qnewtypeFormat name' (tuple (map snd fields)) <> "\n" + else codecomment name <> qrecFormat name' fields + where + name' = reformatTypeName name + isTuple' = fst (fields !! 0) == "0" + fields = map (\f -> (recordFieldName f, unpackedType manifest (recordFieldType f))) $ recordFields ops + +unpackedRecordArrayDec manifest name ops = if isTuple' + then codecomment name <> qnewtypeFormat name' (tuple (map snd fields)) <> "\n" + else codecomment name <> qrecFormat name' fields <> "\n" + where + isTuple' = fst (fields !! 0) == "0" + name' = reformatTypeName name + fields = map (\f -> (recordFieldName f, unpackedType manifest (recordFieldType f))) $ recordArrayFields ops + +objectInstance name = instanceFormat "FutharkObject" [(wname,[])] [rawDec, contextDec, freeDec, wrapDec, pointerDec, counterDec] + where + name' = reformatTypeName name + wname = wrapped name' + constructor = wname + rawDec = typeFormat ("RawObject" <~> wname) (raw name') + contextDec = typeFormat ("ObjectContext" <~> wname) "C.Context" + freeDec = assignment "freeRawObject" (raw "free" <-> name') + wrapDec = assignment "wrapRawObject" constructor + pointerDec = assignment ("objectPointer (" <> constructor <> " _ ptr)") "ptr" + counterDec = assignment ("objectCounter (" <> constructor <> " ctr _)") "ctr" + +sumCompositeInstance manifest name ops = instanceFormat "FutharkComposite" [(wname,[])] [unpackedDec, packDec, unpackDec] + where + name' = reformatTypeName name + wname = wrapped name' + uname = "Unpacked." <> name' + unpackedDec = typeFormat ("Unpacked" <~> wname) uname + payloadid variant = zipWith (\i _ -> "p" <> T.pack (show i)) [0..] (sumVariantPayload variant) + payloadtypes variant = sumVariantPayload variant + packDec = "pack unpacked = unsafeLiftFromIO $ \\ctx\n -> case unpacked of\n" + <> indent (mconcat (map packVariant (sumVariants ops))) + unpackDec = "unpack sum = unsafeLiftFromIO $ \\ctx\n -> " + <> "withRawObject sum $ \\sum -> " + <> "inContext ctx (\\ctx -> Raw.variant_" <> name' <> " ctx sum)" <> " >>= \\variant -> case variant of\n" + <> indent (mconcat (zipWith unpackVariant [0..] (sumVariants ops))) + packVariant variant = "Unpacked." <> name' <-> sumVariantName variant <~> T.unwords (payloadid variant) <> " ->\n" + <> indent ( "" + <> mconcat (zipWith prepareInput (payloadtypes variant) (payloadid variant)) + <> outputInContext ("Raw.construct" <-> name' <-> sumVariantName variant) (payloadid variant) + <> "\n >>= wrapFO ctx >>= \\packed\n -> " + <> mconcat (zipWith (\t id -> if isTuple t + then inContext ("Raw.free_" <> reformatTypeName t) [id] <> "\n >> " + else "") (payloadtypes variant) (payloadid variant)) + <> "pure packed\n" + ) + + unpackVariant i variant = T.pack (show i) <> " -> " + <> mconcat (map (\a -> "alloca $ \\" <> a <> "\n -> ") (payloadid variant)) + <> inContext ("Raw.destruct" <-> name' <-> sumVariantName variant) (payloadid variant ++ ["sum"]) <> "\n >> " + <> mconcat (zipWith (\t a -> "peek " <> a <> processOutput t a) (payloadtypes variant) (payloadid variant)) + <> "pure (" <> "Unpacked." <> name' <-> sumVariantName variant <~> T.unwords (payloadid variant) <> ")\n" + inContext f args = "inContextWithError ctx (\\ctx -> " <> f <> " ctx " <> T.unwords args <> ")" + outputInContext f args = "alloca (\\ptr -> " <> inContext f ("ptr":args) <> " >> peek ptr)" + prepareInput t a = if isPrimitive t + then "" + else if isTuple t + then packTuple manifest t <~> a <> " >>= \\" <> a <> "\n -> " + else "withRawObject" <~> a <~> "$ \\" <> a <> "\n -> " + processOutput t a = if isPrimitive t + then " >>= \\" <> a <> "\n -> " + else if isTuple t + then "\n >>= " <> unpackTuple manifest t <> " >>= \\" <> a <> "\n -> " + else "\n >>= wrapFO ctx >>= \\"<> a <>"\n -> " + +recordCompositeInstance manifest name fields isArr = instanceFormat "FutharkComposite" [(wname,[])] [unpackedDec, packDec, unpackDec] + where + name' = reformatTypeName name + wname = wrapped name' + uname = "Unpacked." <> name' + packfun = if isArr then "zip" else "new" + unpackedDec = typeFormat ("Unpacked" <~> wname) uname + isTuple' = recordFieldName (fields !! 0) == "0" + nums = zipWith (\i _ -> T.pack (show (i::Int))) [0..] fields + fieldid = map ("f"<>) nums + fieldtypes = map recordFieldType fields + fieldnames = map recordFieldName fields + pattern = if isTuple' then tuple fieldid else T.unwords fieldid + packDec = "pack (" <> uname <~> pattern <> ") = unsafeLiftFromIO $ \\ctx\n -> " + <> mconcat (zipWith prepareInput fieldtypes fieldid) + <> outputInContext ("Raw." <> packfun <-> name') fieldid + <> "\n >>= wrapFO ctx >>= \\packed\n -> " + <> mconcat (zipWith (\t id -> if isTuple t + then inContext ("Raw.free_" <> reformatTypeName t) [id] <> "\n >> " + else "") fieldtypes fieldid ) + <> "pure packed\n" + + unpackDec = "unpack packed = unsafeLiftFromIO $ \\ctx\n -> " + <> "withRawObject packed" <~> "$ \\packed\n -> " + <> mconcat (zipWith3 (\n t id -> outputInContext ("Raw.project" <-> name' <-> n) ["packed"] <> processOutput t id) + fieldnames fieldtypes fieldid) + <> "pure (" <> uname <~> pattern <> ")\n" + + inContext f args = "inContextWithError ctx (\\ctx -> " <> f <> " ctx " <> T.unwords args <> ")" + outputInContext f args = "alloca (\\ptr -> " <> inContext f ("ptr":args) <> " >> peek ptr)" + prepareInput t a = if isPrimitive t + then "" + else if isTuple t + then packTuple manifest t <~> a <> " >>= \\" <> a <> "\n -> " + else "withRawObject" <~> a <~> "$ \\" <> a <> "\n -> " + processOutput t a = if isPrimitive t + then " >>= \\" <> a <> "\n -> " + else if isTuple t + then "\n >>= " <> unpackTuple manifest t <> " >>= \\" <> a <> "\n -> " + else "\n >>= wrapFO ctx >>= \\"<> a <>"\n -> " +arrayInstance name futelem rank + = instanceFormat "FutIndexable" [(wname,[])] [rankDec] + <> instanceFormat "FutharkPrimArray'" [(wname,[]), ("C.Context",[]), (rank',[]), (elem',[])] [elemDec, shapeDec, valuesDec, newDec, indexDec] + where + name' = reformatTypeName name + wname = wrapped name' + rank' = "R" <> T.pack (show rank) + elem' = haskellElemType futelem + rankDec = typeFormat ("FutRank" <~> wname) rank' + elemDec = typeFormat ("PrimElem" <~> wname) elem' + newDec = assignment "newFPA" (raw "newArray" <-> name') + shapeDec = assignment "shapeFPA" (raw "shape" <-> name') + valuesDec = assignment "valuesFPA" (raw "values" <-> name') + indexDec = assignment "indexFPA" (raw "index" <-> name') + +opaqueInstance name = instanceFormat "FutharkOpaque" [(wname,[])] [storeDec, restoreDec] + where + name' = reformatTypeName name + wname = wrapped name' + storeDec = assignment "storeOpaque" (raw "store" <-> name') + restoreDec = assignment "restoreOpaque" (raw "restore" <-> name') + +--wrappedTypeOps :: Text -> Type -> Text +wrappedTypeOps manifest name (TypeArray ctype futelem rank ops) = objectInstance name <> arrayInstance name futelem rank +wrappedTypeOps manifest name (TypeOpaque ctype ops mExtraOps doc) = if isTuple name + then "" + else "-- " <> name objectInstance name <> opaqueInstance name <> otherInstances + where + otherInstances = case mExtraOps of + Just (OpaqueSum ops) -> sumCompositeInstance manifest name ops + Just (OpaqueRecord ops) -> recordCompositeInstance manifest name (recordFields ops) False + Just (OpaqueRecordArray ops) -> recordCompositeInstance manifest name (recordArrayFields ops) True + _ -> "" + +rawTypeOps :: Text -> Type -> Text +rawTypeOps name (TypeArray ctype futelem rank ops) = freeDec <> shapeDec <> indexDec <> valuesDec <> newDec <> newRawDec <> valuesRawDec + where + name' = reformatTypeName name + elem = haskellElemType futelem + freeDec = cFFICall ("free" <-> name') (arrayFree ops) + [contextPointer, pointer (raw name')] "Int" + shapeDec = cFFICall ("shape" <-> name') (arrayShape ops) + [contextPointer, pointer (raw name')] (pointer "I64") + indexDec = cFFICall ("index" <-> name') (arrayIndex ops) + (contextPointer : pointer elem : pointer (raw name') : replicate rank "I64") "Int" + valuesDec = cFFICall ("values" <-> name') (arrayValues ops) + [contextPointer, pointer (raw name'), pointer elem] "Int" + valuesRawDec = cFFICall ("valuesRaw" <-> name') (arrayValuesRaw ops) + [contextPointer, pointer (raw name')] (pointer cbyte) + newDec = cFFICall ("newArray" <-> name') (arrayNew ops) + (contextPointer : pointer elem : replicate rank "I64") (pointer $ raw name') + newRawDec = cFFICall ("newArrayRaw" <-> name') (arrayNewRaw ops) + (contextPointer : pointer cbyte : replicate rank "I64") (pointer $ raw name') + +rawTypeOps name (TypeOpaque ctype ops mExtraOps doc) = freeDec <> storeDec <> restoreDec <> extraOpsDec + where + name' = reformatTypeName name + freeDec = cFFICall ("free" <-> name') (opaqueFree ops) + [contextPointer, pointer (raw name')] "Int" + storeDec = cFFICall ("store" <-> name') (opaqueStore ops) + [contextPointer, pointer (raw name'), pointer (pointer cbyte), pointer csize] "Int" + restoreDec = cFFICall ("restore" <-> name') (opaqueRestore ops) + [contextPointer, pointer cbyte] (pointer (raw name')) + extraOpsDec = case mExtraOps of + Nothing -> "" + Just (OpaqueSum ops) -> rawOpaqueSumDec name ops + Just (OpaqueRecord ops) -> rawOpaqueRecordDec name ops + Just (OpaqueArray ops) -> rawOpaqueArrayDec name ops + Just (OpaqueRecordArray ops) -> rawOpaqueRecordArrayDec name ops + _ -> error ("unknown kind of opaque:" <> T.unpack name) + +rawOpaqueSumDec name ops + = cFFICall ("variant" <-> name') (sumVariant ops) [contextPointer, rawHaskellType name] "Int" + <> mconcat (map variantDec $ sumVariants ops) + where + name' = reformatTypeName name + variantDec variant + = cFFICall ("construct" <-> name' <-> sumVariantName variant) (sumVariantConstruct variant) + (contextPointer : pointer (rawHaskellType name) : map rawHaskellType (sumVariantPayload variant)) "Int" + <> cFFICall ("destruct" <-> name' <-> sumVariantName variant) (sumVariantDestruct variant) + (contextPointer : map (pointer . rawHaskellType) (sumVariantPayload variant) <> [rawHaskellType name]) "Int" +rawOpaqueRecordDec name ops + = newDec (recordNew ops) (recordFields ops) + <> mconcat (map fieldDec $ recordFields ops) + where + name' = reformatTypeName name + newDec cfunc fields = cFFICall ("new" <-> name') cfunc + (contextPointer : pointer (rawHaskellType name) : map (rawHaskellType . recordFieldType) fields) "Int" + fieldDec field = cFFICall ("project" <-> name' <-> recordFieldName field) (recordFieldProject field) + [contextPointer, pointer (rawHaskellType $ recordFieldType field), rawHaskellType name] "Int" +rawOpaqueArrayDec name ops = newDec <> setDec <> shapeDec <> indexDec + where + name' = reformatTypeName name + rank = opaqueArrayRank ops + elem = rawHaskellType (opaqueArrayElemType ops) + newDec = cFFICall ("new" <-> name') (opaqueArrayNew ops) + (contextPointer : pointer (rawHaskellType name) : pointer elem : replicate rank "I64") "Int" + setDec = cFFICall ("set" <-> name') (opaqueArraySet ops) + (contextPointer : pointer (rawHaskellType name) : elem : replicate rank "I64") "Int" + shapeDec = cFFICall ("shape" <-> name') (opaqueArrayShape ops) + [contextPointer, pointer (rawHaskellType name)] (pointer "I64") + indexDec = cFFICall ("index" <-> name') (opaqueArrayIndex ops) + (contextPointer : elem : rawHaskellType name : replicate rank "I64") "Int" + +rawOpaqueRecordArrayDec name ops = newDec <> setDec <> shapeDec <> indexDec <> zipDec <> mconcat (map projectDec fields) + where + name' = reformatTypeName name + rank = recordArrayRank ops + elem = rawHaskellType (recordArrayElemType ops) + fields = recordArrayFields ops + newDec = cFFICall ("new" <-> name') (recordArrayNew ops) + (contextPointer : pointer (rawHaskellType name) : pointer elem : replicate rank "I64") "Int" + setDec = cFFICall ("set" <-> name') (recordArraySet ops) + (contextPointer : pointer (rawHaskellType name) : elem : replicate rank "I64") "Int" + shapeDec = cFFICall ("shape" <-> name') (recordArrayShape ops) + [contextPointer, pointer (rawHaskellType name)] (pointer "I64") + indexDec = cFFICall ("index" <-> name') (recordArrayIndex ops) + (contextPointer : elem : rawHaskellType name : replicate rank "I64") "Int" + zipDec = cFFICall ("zip" <-> name') (recordArrayZip ops) + (contextPointer : pointer (rawHaskellType name) : map (rawHaskellType . recordFieldType) fields) "Int" + projectDec field = cFFICall ("project" <-> name' <-> recordFieldName field) (recordFieldProject field) + [contextPointer, pointer (rawHaskellType $ recordFieldType field), rawHaskellType name] "Int" + + +isConvertible manifest t = case M.lookup t (manifestTypes manifest) of + Nothing -> True --Primitive + Just t' -> case t' of + (TypeArray _ _ _ _) -> True + (TypeOpaque _ _ ops _) -> case ops of + Nothing -> False + Just ops' -> case ops' of + (OpaqueArray _) -> False --fix eventually + (OpaqueRecordArray o) -> and (map (check . recordFieldType) (recordArrayFields o)) + (OpaqueRecord o) -> and (map (check . recordFieldType) (recordFields o)) + (OpaqueSum o) -> and (map (and . map check . sumVariantPayload) (sumVariants o)) + where + check = isConvertible manifest + +mutable t = "Mutable" <> t +nativeSumDec manifest name ops = + (codecomment name <> sumFormat' name' (map variant $ sumVariants ops), elementDec) + where + variant v = (name' <-> sumVariantName v, map nativeType $ sumVariantPayload v) + name' = reformatTypeName name + elementDec = instanceFormat ("Element") [(name',[])] + [ typeFormat ("Array " <> name') ("BArray " <> name') + , typeFormat ("MArray " <> name') ("MBArray " <> name') + , "size = sizeB\n" + , "msize = msizeB\n" + , "unsafeRead = unsafeReadB\n" + , "unsafePeek = unsafePeekB\n" + , "unsafePoke = unsafePokeB\n" + , "unsafeThaw = unsafeThawB\n" + , "unsafeFreeze = unsafeFreezeB\n" + , "unsafeSlice = unsafeSliceB\n" + , "scratch = scratchB\n" + ] + +nativeRecordDec manifest name ops = if isTuple name + then ("","") + else if isTuple' + then (codecomment name <> newtypeFormat' (reformatTypeName name) (tuple (map snd fields)) <> "\n", elementDec) + else (codecomment name <> recFormat' (reformatTypeName name) fields, elementDec) + where + elementDec = idec <> mdec <> arrdec <> elemdec <> zipdec <> unzipdec <> showdec :: Text + name' = reformatTypeName name + isTuple' = fst (fields !! 0) == "0" + fields = map (\f -> (recordFieldName f, nativeType (recordFieldType f))) $ recordFields ops + icon' = "Array_" <> name' + mcon' = "MArray_" <> name' + array a = "Array " <> wrapIfNotWrappedOrSingleton a + marray a = "M" <> array a + econ vars = if isTuple' + then name' <~> tuple vars + else name' <~> T.unwords (map wrapIfNotWrappedOrSingleton vars) + icon vars = icon' <~> T.unwords (map wrapIfNotWrappedOrSingleton vars) + mcon vars = mcon' <~> T.unwords (map wrapIfNotWrappedOrSingleton vars) + nums = map (T.pack . show) [0..length fields-1] + vars = map ("a"<>) nums + elems = map ("e"<>) nums + idec = "data" <~> icon' <=> icon (map (wrap.array.snd) fields) <> "\n" + mdec = "data" <~> mcon' <=> mcon (map (wrap.marray.snd) fields) <> "\n" + arrdec = instanceFormat "Element" + [(name', [])] + [ typeFormat ("Array " <> name' ) icon' + , typeFormat ("MArray " <> name' ) mcon' + , "size (" <> icon vars <> ") = size a0\n" + , "msize (" <> mcon vars <> ") = msize a0\n" + , "unsafeRead (" <> icon vars <> ") idx = " <> econ (map (\v -> "unsafeRead " <> v <> " idx") vars) <> "\n" + , "unsafePeek (" <> mcon vars <> ") idx = do\n" + <> mconcat (zipWith (\v e -> " " <> e <> " <- unsafePeek " <> v <> " idx\n") vars elems) + <> " pure (" <> econ elems <> ")\n" + , "unsafePoke (" <> mcon vars <> ") idx (" <> econ elems <> ") = do\n" + <> mconcat (zipWith (\v e -> " unsafePoke " <> v <> " idx " <> e <>"\n") vars elems) + --, "copy (" <> mcon vars <> ") = do\n" + -- <> mconcat (map (\v -> " " <> v <> "' <- copy " <> v <> "\n") vars) + -- <> " pure (" <> mcon (map (<>"'") vars) <> ")\n" + , "unsafeThaw (" <> icon vars <> ") = do\n" + <> mconcat (map (\v -> " " <> v <> "' <- unsafeThaw " <> v <> "\n") vars) + <> " pure (" <> mcon (map (<>"'") vars) <> ")\n" + , "unsafeFreeze (" <> mcon vars <> ") = do\n" + <> mconcat (map (\v -> " " <> v <> "' <- unsafeFreeze " <> v <> "\n") vars) + <> " pure (" <> icon (map (<>"'") vars) <> ")\n" + , "unsafeSlice (" <> icon vars <> ") i s = " <> icon (map (\v -> "(unsafeSlice " <> v <> " i s)") vars) + <> "\n" + , "scratch s = do\n" + <> mconcat (map (\v -> " " <> v <> " <- scratch s\n") vars) + <> " pure (" <> mcon vars <> ")\n" + ] + elemdec = instanceFormat ("Element") [(icon',[])] + [ typeFormat ("Array " <> icon') ("BArray " <> icon') + , typeFormat ("MArray " <> icon') ("MBArray " <> icon') + , "size = sizeB\n" + , "msize = msizeB\n" + , "unsafeRead = unsafeReadB\n" + , "unsafePeek = unsafePeekB\n" + , "unsafePoke = unsafePokeB\n" + , "unsafeThaw = unsafeThawB\n" + , "unsafeFreeze = unsafeFreezeB\n" + , "unsafeSlice = unsafeSliceB\n" + , "scratch = scratchB\n" + ] + zipdec = "" + <> "zip_" <> name' <> " :: " + <> mconcat (map (\f -> array (snd f) <> " -> ") fields) + <> "Array " <> name' <> "\n" + <> "zip_" <> name' <~> T.unwords vars <=> (if length vars > 1 + then "if " <> T.intercalate " && " (zipWith (\v v' -> "size " <> v <> " == " <> "size " <> v') vars (tail vars)) <> "\n" + <> " then " <> icon vars <> "\n" + <> " else error \"sizes of arguments do not match\"\n" + else icon vars <> "\n") + unzipdec = "" + <> "unzip_" <> name' <> " :: " + <> "Array " <> name' <> " -> " <> tuple (map (array.snd) fields) <> "\n" + <> "unzip_" <> name' <~> wrap (icon vars) <=> tuple vars <> "\n" + showdec = instanceFormat + "Show" + [(icon',[])] + [ "show = show . toList\n" ] + +nativeOpaqueArrayDec manifest name ops = (codecomment name <> if isArr + then typeFormat name' (nativeType name) + <> "\n" + else newtypeFormat' name' (wrap innerType) + <> "\n" + , "" ) + where + innerType = nativeType (mconcat (replicate (opaqueArrayRank ops) "[]") <> opaqueArrayElemType ops) + isArr = take 2 (T.unpack name) == "[]" + name' = reformatTypeName name + +nativeRecordArrayDec manifest name ops = (codecomment name <> if isArr + then typeFormat name' (nativeType name) + <> "\n" + else newtypeFormat' name' (wrap innerType) + <> "\n" + , "" ) + where + innerType = nativeType (mconcat (replicate (recordArrayRank ops) "[]") <> recordArrayElemType ops) + isArr = take 2 (T.unpack name) == "[]" + name' = reformatTypeName name + + + +nativeTypeDec manifest name (TypeArray ctype futelem rank ops) = (codecomment name <> staticDec <> "\n","") + where + name' = reformatTypeName name + elem = capitalize futelem + staticDec = typeFormat name' (arrayType rank) + arrayType rank = if rank == 1 then "Array " <> elem else "Array (" <> arrayType (rank-1) <> ")" +nativeTypeDec manifest name (TypeOpaque ctype ops mExtraOps _) = case mExtraOps of + Nothing -> ("","") + Just (OpaqueSum ops) -> nativeSumDec manifest name ops + Just (OpaqueRecord ops) -> nativeRecordDec manifest name ops + Just (OpaqueArray ops) -> nativeOpaqueArrayDec manifest name ops + Just (OpaqueRecordArray ops) -> nativeRecordArrayDec manifest name ops + _ -> error ("unknown kind of opaque:" <> T.unpack name) +conversionDec manifest name (TypeArray ctype futelem rank ops) = instanceFormat "Convertible" [(wname,[])] + [native, toFuthark, fromFuthark] + where + name' = reformatTypeName name + wname = "Futhark." <> name' + nname = "Haskell." <> name' + native = typeFormat ("Native" <~> wname) nname + szs = map (\i -> "sz"<> T.pack (show i)) [0..rank-1] + idxs = map (\i -> "idx"<> T.pack (show i)) [0..rank-1] + toFuthark = if rank == 1 + then "toFuthark (SArray sz ptr) = unsafeLiftFromIO $ \\ctx" + "-> inContext ctx $ \\cp" + "-> F.withForeignPtr ptr $ \\ap" + "-> Raw.newArray_" <> name' <> " cp ap (fromIntegral sz) >>= wrapFO ctx\n" + else "toFuthark arr = let " <> tuple szs <=> tuple (map (\r -> "size (arr " <> mconcat (replicate r "! 0") <> ")" ) [0..rank-1]) <> " in unsafeLiftFromIO $ \\ctx" + "-> inContext ctx $ \\cp" + "-> F.allocaArray (" <> T.intercalate "*" szs <> ") $ \\tmp" + "-> sequence ((\\" <> T.unwords (init idxs) <> " -> pure (arr" <> mconcat (map (" ! "<>) (init idxs)) <> ") >>= \\(SArray sz ptr) -> if sz == " <> last szs + " then F.withForeignPtr ptr (\\ap -> F.copyArray ap (F.advancePtr tmp (" <> T.intercalate "+" (zipWith (\a b -> a<>"*"<>b) (tail szs) (init idxs)) <> ")) sz)" + " else error \"Uneven array can not be converted\") <$> " <> T.intercalate " <*> " (map (\sz -> "[0.." <> sz <> "-1]") $ init szs) <> ")" + ">> Raw.newArray_" <> name' <> " cp tmp " <> T.unwords (map (wrap.("fromIntegral " <>)) szs) <>" >>= wrapFO ctx\n" + + fromFuthark = "fromFuthark arr = unsafeLiftFromIO $ \\ctx" + "-> inContext ctx $ \\cp" + "-> withRawObject arr $ \\fp" + "-> Raw.shape_" <> name' <> " cp fp >>= \\sp" + <> mconcat (zipWith (\i sz -> "\n -> fmap fromIntegral (F.peekElemOff sp " <> T.pack (show i) <> ") >>= \\" <> sz <> "") [0..] szs) + "-> pure (" <> T.intercalate "*" szs <> ") >>= \\sz" + "-> F.mallocForeignPtrArray sz >>= \\ptr" + + + "-> F.withForeignPtr ptr (\\ap -> Raw.values_" <> name' <> " cp fp ap)" + ">> sync ctx" + ">> pure (SArray sz ptr)" <> if rank == 1 + then "\n" + else " >>= \\arr " + "-> pure (" + <> mconcat (zipWith (\i sz -> "A.tabulate " <> sz <> " $ \\" <> i <> " -> ") (init idxs) szs) + <> "A.unsafeSlice arr ("<> T.intercalate "*" (last szs:init idxs) <> ") " <> last szs <> ")" + + + +conversionDec manifest name (TypeOpaque ctype ops mExtraOps doc) = if not (isConvertible manifest name) + then "" + else case mExtraOps of + Nothing -> "" + Just (OpaqueSum ops) -> conversionSumDec manifest name ops + Just (OpaqueRecord ops) -> conversionRecordDec manifest name ops + Just (OpaqueArray ops) -> conversionArrayDec manifest name ops + Just (OpaqueRecordArray ops) -> conversionRecordArrayDec manifest name ops + _ -> error ("unknown kind of opaque:" <> T.unpack name) + +conversionSumDec manifest name ops = instanceFormat "Convertible" [(wname,[])] [native, toFuthark, fromFuthark] + where + name' = reformatTypeName name + wname = "Futhark." <> name' + uname = "Unpacked." <> name' + nname = "Haskell." <> name' + native = typeFormat ("Native" <~> wname) nname + fieldtype t = if isTuple t + then mconcat $ map fieldtype (subtypes t) + else [t] + fieldid prefix t = if isTuple t + then mconcat $ zipWith (\i -> fieldid (prefix <-> T.pack (show i))) [0..] (subtypes t) + else [prefix] + tuplePattern prefix t = if isTuple t + then tuple $ zipWith (\i -> tuplePattern (prefix <-> T.pack (show i))) [0..] (subtypes t) + else prefix + payloadtypes variant = mconcat $ map fieldtype (sumVariantPayload variant) + payloadids variant = mconcat $ zipWith (fieldid) (map (\i -> "p" <> T.pack (show i)) [0..]) (sumVariantPayload variant) + pattern variant = + let items = zipWith tuplePattern (map (\i -> "p" <> T.pack (show i)) [0..]) (sumVariantPayload variant) + in T.unwords items + subtypes t = case M.lookup t (manifestTypes manifest) of + Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops) + _ -> error "nontuple type" + subargs t = zipWith (\i _ -> "t" <> T.pack (show i)) [0..] (subtypes t) + fromFuthark = "fromFuthark packed = unsafeFromFutIO $ do\n" <> indent ("" + <> "unpacked <- unpack packed\n" + <> "case unpacked of\n" + <> indent (mconcat (map fromFutharkVariant (sumVariants ops))) + ) + toFuthark = "toFuthark native = unsafeFromFutIO $ do\n" <> indent ("" + <> "case native of\n" + <> indent (mconcat (map toFutharkVariant (sumVariants ops))) + ) + fromFutharkVariant variant = uname <-> sumVariantName variant <~> pattern variant <> " -> do\n" <> indent ("" + <> mconcat (zipWith (\t i -> if isPrimitive t + then "" + else i <> " <- fromFuthark " <> i <> " >>= \\" <> i <> "' -> finalizeFO " <> i <> " >> pure " <> i <> "'\n") + (payloadtypes variant) (payloadids variant)) + <> "pure (" <> nname <-> sumVariantName variant <~> pattern variant <> ")\n" + ) + toFutharkVariant variant = nname <-> sumVariantName variant <~> pattern variant <> " -> do\n" <> indent ("" + <> mconcat (zipWith (\t i -> if isPrimitive t + then "" + else i <> " <- toFuthark " <> i <> "\n") + (payloadtypes variant) (payloadids variant)) + <> "packed <- pack $ " <> uname <-> sumVariantName variant <~> (pattern variant) <> "\n" + <> mconcat (zipWith (\t i -> if isPrimitive t + then "" + else "finalizeFO " <> i <> "\n") + (payloadtypes variant) (payloadids variant)) + <> "pure packed\n" + ) +conversionRecordDec manifest name ops = if isTuple name + then "" + else instanceFormat "Convertible" [(wname,[])] [native, toFuthark, fromFuthark] + where + name' = reformatTypeName name + fields = recordFields ops + isTuple' = recordFieldName (fields !! 0) == "0" + wname = "Futhark." <> name' + uname = "Unpacked." <> name' + nname = "Haskell." <> name' + fieldtype t = if isTuple t + then mconcat $ map fieldtype (subtypes t) + else [t] + fieldid prefix t = if isTuple t + then mconcat $ zipWith (\i -> fieldid (prefix <-> T.pack (show i))) [0..] (subtypes t) + else [prefix] + tuplePattern prefix t = if isTuple t + then tuple $ zipWith (\i -> tuplePattern (prefix <-> T.pack (show i))) [0..] (subtypes t) + else prefix + fieldtypes = mconcat $ map (fieldtype . recordFieldType) fields + fieldids = mconcat $ zipWith (fieldid) (map (\i -> "f" <> T.pack (show i)) [0..]) (map recordFieldType fields) + pattern = let items = zipWith tuplePattern (map (\i -> "f" <> T.pack (show i)) [0..]) (map recordFieldType fields) + in if isTuple' then tuple items else T.unwords items + native = typeFormat ("Native" <~> wname) nname + subtypes t = case M.lookup t (manifestTypes manifest) of + Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops) + _ -> error "nontuple type" + subargs t = zipWith (\i _ -> "t" <> T.pack (show i)) [0..] (subtypes t) + fromFuthark = "fromFuthark packed = unsafeFromFutIO $ do\n" <> indent ("" + <> uname <~> pattern <> " <- unpack packed\n" + <> mconcat (zipWith (\t a -> if isPrimitive t + then "" + else a <> " <- fromFuthark " <> a <> " >>= \\" <> a <> "' -> finalizeFO " <> a <> " >> pure " <> a <> "'\n") + fieldtypes fieldids) + <> "pure (" <> nname <~> pattern <> ")\n" + ) + toFuthark = "toFuthark (" <> nname <~> pattern <> ") = unsafeFromFutIO $ do\n" <> indent ("" + <> mconcat (zipWith (\t a -> if isPrimitive t + then "" + else a <> " <- toFuthark " <> a <> "\n") + fieldtypes fieldids) + <> "packed <- pack (" <> uname <~> pattern <> ")\n" + <> mconcat (zipWith (\t a -> if isPrimitive t + then "" + else "finalizeFO " <> a <> "\n") + fieldtypes fieldids) + <> "pure packed\n" + ) + +conversionRecordArrayDec manifest name ops = instanceFormat "Convertible" [(wname,[])] [native, toFuthark, fromFuthark] + where + name' = reformatTypeName name + fields = recordArrayFields ops + ename = reformatTypeName $ recordArrayElemType ops + fieldN = T.pack (show (length fields)) + rank = recordArrayRank ops + (zipFun, unzipFun) = if isTuple (recordArrayElemType ops) + then ("A.zip" <> fieldN, "A.unzip" <> fieldN) + else ("Haskell.zip_" <> ename, "Haskell.unzip_" <> ename) + unzipArr rank = if rank > 1 + then "A.unzip" <> fieldN <> " . A.map " <> wrapIfNotOneWord (unzipArr (rank-1)) + else unzipFun + zipArr rank = if rank > 1 + then "A.map" <> fieldN <~> wrapIfNotOneWord (zipArr (rank-1)) + else zipFun + isTuple' = recordFieldName (fields !! 0) == "0" + isArr = take 2 (T.unpack name) == "[]" + deArr = T.dropWhile (\c -> c == '[' || c == ']') + isTupleArr = isTuple . deArr + tupleArr = "T" <> T.pack (show (length fields)) <> "Array" + recordArr = "Haskell.Array_" <> reformatTypeName (recordArrayElemType ops) + wname = "Futhark." <> name' + uname = "Unpacked." <> name' + nname = "Haskell." <> name' + fieldtypes = map recordFieldType fields + fieldids = zipWith (\i _ -> "f" <> T.pack (show i)) [0..] fields + upattern = uname <~> if isTuple' then tuple fieldids else T.unwords fieldids + native = typeFormat ("Native" <~> wname) nname + fromFuthark = "fromFuthark packed = unsafeFromFutIO $ do\n" <> indent ("" + <> upattern <> " <- unpack packed\n" + <> mconcat (zipWith (\t a -> if isPrimitive t + then "" + else a <> " <- fromFuthark " <> a <> " >>= \\" <> a <> "' -> finalizeFO " <> a <> " >> pure " <> a <> "'\n") + fieldtypes fieldids) + <> "pure $ " <> (if isArr then "" else nname <> " $ ") <> zipArr rank <~> T.unwords fieldids + ) + toFuthark = "toFuthark "<> (if isArr then "arr" else wrap (nname <> " arr")) <>" = unsafeFromFutIO $ do\n" <> indent ("" + <> tuple fieldids <> " <- pure . " <> unzipArr rank <> " $ arr\n" + <> mconcat (zipWith (\t a -> if isPrimitive t + then "" + else a <> " <- toFuthark " <> a <> "\n") + fieldtypes fieldids) + <> "packed <- pack (" <> upattern <> ")\n" + <> mconcat (zipWith (\t a -> if isPrimitive t + then "" + else "finalizeFO " <> a <> "\n") + fieldtypes fieldids) + <> "pure packed\n" + ) + +conversionArrayDec manifest name ops = instanceFormat "Convertible" [(wname,[])] [native, toFuthark, fromFuthark] + where + name' = reformatTypeName name + wname = "Futhark." <> name' + uname = "Unpacked." <> name' + nname = "Haskell." <> name' + native = typeFormat ("Native" <~> wname) nname + fromFuthark = "fromFuthark = undefined\n" + toFuthark = "toFuthark = undefined\n" + +rawTypeUtil name _ = error $ "unknown type: " <> T.unpack name + +typeDec :: Text -> Type -> Text +typeDec name (TypeArray ctype futelem rank ops) = undefined +typeDec name (TypeOpaque ctype ops mExtraOps doc) = undefined +typeDec name _ = error $ "unknown type: " <> T.unpack name + + + +rawEntryCalls = M.foldr (<>) "" . M.mapWithKey rawEntryCall . manifestEntryPoints +rawTypeOpss = M.foldr (<>) "" . M.mapWithKey rawTypeOps . manifestTypes +rawTypeDecs = M.foldr (<>) "" . M.mapWithKey rawTypeDec . manifestTypes +wrappedTypeDecs = M.foldr (<>) "" . M.mapWithKey wrappedTypeDec . manifestTypes +wrappedTypeOpss manifest = M.foldr (<>) "" . M.mapWithKey (wrappedTypeOps manifest) . manifestTypes $ manifest +unpackedTypeDecs manifest = M.foldr (<>) "" . M.mapWithKey (unpackedTypeDec manifest) . manifestTypes $ manifest +conversionDecs manifest = M.foldr (<>) "" . M.mapWithKey (conversionDec manifest) . manifestTypes $ manifest +wrappedEntryCalls manifest = (\(docs, calls) -> docs <> calls) + $ M.foldr (\(doc1, call1) (doc2, call2) -> (doc1 <> doc2, call1 <> call2)) ("", "") + . M.mapWithKey (wrappedEntryCall manifest) . manifestEntryPoints $ manifest +nativeTypeDecs manifest = (\(decs, instances) -> hcomment "Types mirroring those in the manifest" <> "\n" <> decs <> "\n" <> hcomment "Element instances and functions" <> "\n" <> instances) + $ M.foldr (\(dec1, inst1) (dec2, inst2) -> (dec1 <> dec2, inst1 <> inst2)) ("", "") + . M.mapWithKey (nativeTypeDec manifest) . manifestTypes $ manifest + + +typetest = do + manifest <- readManifest "test.json" + putText $ rawEntryCalls manifest + putText $ rawTypeOpss manifest + putText $ rawTypeDecs manifest + putText $ wrappedTypeDecs manifest + putText $ wrappedTypeOpss manifest + putText $ nativeTypeDecs manifest + putText $ conversionDecs manifest + pure () + + +--generate mapN for array module +arrMapN :: Int -> Text +arrMapN n = typedec <> mapdec + where + n' = T.pack (show n) + elems = take (n+1) $ map (\i -> "e" <> T.pack (show i)) [0..] + vars = take n $ map (\i -> "a" <> T.pack (show i)) [0..] + typedec = "map" <> n' + <> " :: " <> tuple (map ("Element "<>) elems) + <> " => " <> wrap (T.intercalate " -> " elems) + <> mconcat (map (" -> Array "<>) elems) + <> "\n" + mapdec = "map" <> n' <> " f " <> T.unwords vars + <=> "if " <> T.intercalate " && " (zipWith (\a b -> "size " <> a <> " == size " <> b) vars (tail vars)) + "then tabulate (size a0) (\\idx -> f " <> T.unwords (map (\v -> "(unsafeRead " <> v <> " idx)") vars) <> ")" + "else error \"sizes of arguments do not match\"" + "\n" + +--generate tuple arrays +tupleArray :: Int -> Text +tupleArray i = idec <> mdec <> arrdec <> elemdec <> showdec <> zipdec <> unzipdec + where + icon' = "T" <> T.pack (show i) <> "Array" + mcon' = "M" <> icon' + icon vars = icon' <~> T.unwords vars + mcon vars = mcon' <~> T.unwords vars + nums = map (T.pack . show) [0..i-1] + vars = map ("a"<>) nums + elems = map ("e"<>) nums + idec = "data" <~> icon vars <> " where\n " + <> icon' <> " :: " + <> tuple (map ("Element " <>) vars) <> " => " + <> mconcat (map (\v -> "Array " <> v <> " -> ") vars) + <> icon vars <> "\n" + mdec = "data" <~> mcon vars <> " where\n " + <> mcon' <> " :: " + <> tuple (map ("Element " <>) vars) <> " => " + <> mconcat (map (\v -> "MArray " <> v <> " -> ") vars) + <> mcon vars <> "\n" + arrdec = instanceFormat ( tuple ( map ("Element" <~>) vars) <> " => Element" ) + [(tuple vars, [])] + [ typeFormat ("Array " <> tuple vars ) (icon vars) + , typeFormat ("MArray " <> tuple vars ) (mcon vars) + , "size (" <> icon vars <> ") = size a0\n" + , "msize (" <> mcon vars <> ") = msize a0\n" + , "unsafeRead (" <> icon vars <> ") idx = " <> tuple (map (\v -> "unsafeRead " <> v <> " idx") vars) <> "\n" + , "unsafePeek (" <> mcon vars <> ") idx = do\n" + <> mconcat (zipWith (\v e -> " " <> e <> " <- unsafePeek " <> v <> " idx\n") vars elems) + <> " pure " <> tuple elems <> "\n" + , "unsafePoke (" <> mcon vars <> ") idx " <> tuple elems <> " = do\n" + <> mconcat (zipWith (\v e -> " unsafePoke " <> v <> " idx " <> e <>"\n") vars elems) + --, "copy (" <> mcon vars <> ") = do\n" + -- <> mconcat (map (\v -> " " <> v <> "' <- copy " <> v <> "\n") vars) + -- <> " pure (" <> mcon (map (<>"'") vars) <> ")\n" + , "unsafeThaw (" <> icon vars <> ") = do\n" + <> mconcat (map (\v -> " " <> v <> "' <- unsafeThaw " <> v <> "\n") vars) + <> " pure (" <> mcon (map (<>"'") vars) <> ")\n" + , "unsafeFreeze (" <> mcon vars <> ") = do\n" + <> mconcat (map (\v -> " " <> v <> "' <- unsafeFreeze " <> v <> "\n") vars) + <> " pure (" <> icon (map (<>"'") vars) <> ")\n" + , "unsafeSlice (" <> icon vars <> ") i s = " <> icon (map (\v -> "(unsafeSlice " <> v <> " i s)") vars) + <> "\n" + , "scratch s = do\n" + <> mconcat (map (\v -> " " <> v <> " <- scratch s\n") vars) + <> " pure (" <> mcon vars <> ")\n" + ] + elemdec = instanceFormat ("Element") [(wrap (icon vars),[])] + [ typeFormat ("Array " <> wrap (icon vars)) ("BArray " <> wrap (icon vars)) + , typeFormat ("MArray " <> wrap (icon vars)) ("MBArray " <> wrap (icon vars)) + , "size = sizeB\n" + , "msize = msizeB\n" + , "unsafeRead = unsafeReadB\n" + , "unsafePeek = unsafePeekB\n" + , "unsafePoke = unsafePokeB\n" + , "unsafeThaw = unsafeThawB\n" + , "unsafeFreeze = unsafeFreezeB\n" + , "unsafeSlice = unsafeSliceB\n" + , "scratch = scratchB\n" + ] + zipdec = "" + <> "zip" <> T.pack (show i) <> " :: " <> tuple (map ("Element " <> ) vars) <> " => " + <> mconcat (map (\v -> "Array " <> v <> " -> ") vars) + <> "Array " <> tuple vars <> "\n" + <> "zip" <> T.pack (show i) <~> T.unwords vars <=> "if " <> T.intercalate " && " (zipWith (\v v' -> "size " <> v <> " == " <> "size " <> v') vars (tail vars)) <> "\n" + <> " then " <> icon vars <> "\n" + <> " else error \"sizes of arguments do not match\"\n" + unzipdec = "" + <> "unzip" <> T.pack (show i) <> " :: " <> tuple (map ("Element " <> ) vars) <> " => " + <> "Array " <> tuple vars <> " -> " <> tuple (map ("Array " <>) vars) <> "\n" + <> "unzip" <> T.pack (show i) <~> wrap (icon vars) <=> tuple vars <> "\n" + showdec = instanceFormat + (tuple ( map ("Show " <>) vars ++ map ("Element " <>) vars ) <> " => Show") + [(wrap (icon vars),[])] + [ "show = show . toList\n" ] + + + diff --git a/src/Context.hs b/src/Context.hs new file mode 100644 --- /dev/null +++ b/src/Context.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Context where +import qualified Futhark.Manifest as FM +import Backends +import CodeGen + +rawContextDec manifest = tuningCalls configCalls manifest contextCalls + where + tuningCalls = "" + cFFICall "get_tuning_param_count" "futhark_get_tuning_param_count" [] int + cFFICall "get_tuning_param_name" "futhark_get_tuning_param_name" [int] string + cFFICall "get_tuning_param_class" "futhark_get_tuning_param_class" [int] string + configCalls backend = "data Config" + cFFICall "config_new" "futhark_context_config_new" [] config + cFFICall "config_free" "futhark_context_config_free" [config] empty + cFFICall "config_set_debugging" "futhark_context_config_set_debugging" [config, int] empty + cFFICall "config_set_profiling" "futhark_context_config_set_profiling" [config, int] empty + cFFICall "config_set_logging" "futhark_context_config_set_logging" [config, int] empty + cFFICall "config_set_tuning_param" "futhark_context_config_set_tuning_param" [config, string, size] int + cFFICall "config_set_cache_file" "futhark_context_config_set_cache_file" [config, string] empty + case FM.manifestBackend manifest of + "c" -> c_config + "multicore" -> multicore_config + "opencl" -> gpu_config <> opencl_config + "cuda" -> gpu_config <> cuda_config + "hip" -> gpu_config + c_config = "" + multicore_config = cFFICall "config_set_num_threads" "futhark_context_config_set_num_threads" [config, int] empty + gpu_config + = cFFICall "config_set_device" "futhark_context_config_set_device" [config, string] empty + cFFICall "config_set_unified_memory" "futhark_context_config_set_unified_memory" [config, int] empty + cFFICall "config_set_default_thread_block_size" "futhark_context_config_set_default_thread_block_size" [config, int] empty + cFFICall "config_set_default_group_size" "futhark_context_config_set_default_group_size" [config, int] empty + cFFICall "config_set_default_grid_size" "futhark_context_config_set_default_grid_size" [config, int] empty + + cFFICall "config_set_default_group_num" "futhark_context_config_set_default_group_num" [config, int] empty + + cFFICall "config_set_default_tile_size" "futhark_context_config_set_default_tile_size" [config, int] empty + + cFFICall "config_get_program" "futhark_context_config_get_program" [config] string + cFFICall "config_set_program" "futhark_context_config_set_program" [config, string] empty + opencl_config + = cFFICall "config_set_platform" "futhark_context_config_set_platform" [config, string] empty + cFFICall "config_add_build_option" "futhark_context_config_add_build_option" [config, string] empty + cuda_config + = cFFICall "config_add_nvrtc_option" "futhark_context_config_add_nvrtc_option" [config, string] empty + cFFICall "config_dump_ptx_to" "futhark_context_dump_ptx_to" [config, string] empty + cFFICall "config_load_ptx_from" "futhark_context_load_ptx_from" [config, string] empty + contextCalls = "data Context" + cFFICall "context_new" "futhark_context_new" [config] context + cFFICall "context_free" "futhark_context_free" [context] empty + cFFICall "context_sync" "futhark_context_sync" [context] int + cFFICall "context_get_error" "futhark_context_get_error" [context] text + cFFICall "context_set_logging_file" "futhark_context_set_logging_file" [context, file] empty + cFFICall "context_pause_profiling" "futhark_context_pause_profiling" [context] empty + cFFICall "context_unpause_profiling" "futhark_context_unpause_profiling" [context] empty + cFFICall "context_report" "futhark_context_report" [context] text + cFFICall "context_clear_caches" "futhark_context_clear_caches" [context] int + config = pointer "Config" + context = pointer "Context" + file = pointer "CFile" + text = pointer "CChar" + string = "CString" + int = "Int" + size = "CSize" + empty = "()" + +wrappedContextDec manifest + = newtypeFormat "Context" "(Futhask.ReferenceCounter, ForeignPtr (Raw.Context))" + "instance Futhask.Context" <~> ctx <~> "where" + "type RawContext" <~> ctx <=> rctx + "type RawConfig" <~> ctx <=> rcfg + "wrapRawContext" <=> ctx + "unwrapRawContext (" <> ctx <>" a) = a" + "newContext" <=> raw "context_new" + "freeContext" <=> raw "context_free" + "syncContext" <=> raw "context_sync" + "clearCaches" <=> raw "context_clear_caches" + "getError" <=> raw "context_get_error" + "getReport" <=> raw "context_report" + "pauseProfiling" <=> raw "context_pause_profiling" + "unpauseProfiling" <=> raw "context_unpause_profiling" + "newConfig" <=> raw "config_new" + "freeConfig" <=> raw "config_free" + "setTuningParam" <=> raw "config_set_tuning_param" + "setCacheFile" <=> raw "config_set_cache_file" + "setDebug" <=> raw "config_set_debugging" + "setLog" <=> raw "config_set_logging" + "setProfile" <=> raw "config_set_profiling" + "setDevice" <=> (if gpu then raw "config_set_device" else nothing) + "setDefaultThreadBlockSize" <=> (if gpu then raw "config_set_default_thread_block_size" else nothing) + "setDefaultGridSize" <=> (if gpu then raw "config_set_default_grid_size" else nothing) + "setDefaultTileSize" <=> (if gpu then raw "config_set_default_tile_size" else nothing) + "setPlatform" <=> (if opencl then raw "config_set_platform" else nothing) + "setBuildOption" <=> (if opencl then raw "config_set_build_option" else nothing) + "setNvrtcOption" <=> (if cuda then raw "config_set_nvrtc_option" else nothing) + "setNumThreads" <=> (if multicore then raw "config_set_num_threads" else nothing) + "-- | Make new context with a list of options" + "mkContext :: [Futhask.ContextOption] -> IO (Context, [String])" + "mkContext = Futhask.mkContext" + where + nothing = "(\\_ _ -> pure ())" + raw a = "Raw." <> a + ctx = "Context" + cfg = "Config" + rctx = raw ctx + rcfg = raw cfg + gpu = case FM.manifestBackend manifest of + "opencl" -> True + "cuda" -> True + "hip" -> True + _ -> False + opencl = case FM.manifestBackend manifest of + "opencl" -> True + _ -> False + cuda = case FM.manifestBackend manifest of + "cuda" -> True + _ -> False + multicore = case FM.manifestBackend manifest of + "multicore" -> True + _ -> False diff --git a/src/Conversion.hs b/src/Conversion.hs deleted file mode 100644 --- a/src/Conversion.hs +++ /dev/null @@ -1,180 +0,0 @@ -module Conversion where - -import Data.Maybe -import Data.List (intercalate, partition, lookup) -import Data.Char (toUpper) -import Text.ParserCombinators.ReadP -import Debug.Trace - -data HeaderItem - = Preproc String - | Comment String - | Fun (String, String) [(String, String)] - | Var (String, String) - deriving Show - -readExtern = fmap Preproc $ (string "extern") >> manyTill get (char '\n') -readExtern2 = fmap Preproc $ (char '}') >> manyTill get (char '\n') - -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 >> readExtern <++ readExtern2 <++ 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") - , ("unsigned char", "CUChar") - , ("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") - , ("FILE", "CFile") - , ("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 (intercalate " " 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 = "\ndata " ++ cn ++ " c = " ++ cn ++ " (MV.MVar Int) (F.ForeignPtr Raw." ++ rn ++ ")\n" - ++ "instance FutharkObject " ++ cn ++ " Raw." ++ rn ++ " where\n" - ++ " wrapFO = " ++ cn ++ "\n" - ++ " freeFO = Raw.free_" ++ sn ++ "\n" - ++ " fromFO (" ++ cn ++ " rc fp) = (rc, 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 (intercalate " " ts) varTable of - Just s -> s; - Nothing -> error $ (trace (show ts)) "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 :: Monad m \n => " - ++ concatMap (\i -> haskellType' (fst i) ++ "\n -> " ) inArgs - ++ "FutT c m " ++ wrapIfNotOneWord (intercalate ", " $ map (\o -> haskellType' $ fst o) outArgs) ++ "\n" - input = unwords (en : map snd inArgs) ++ "\n = Fut.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 diff --git a/src/Headers.hs b/src/Headers.hs --- a/src/Headers.hs +++ b/src/Headers.hs @@ -1,123 +1,288 @@ +{-# LANGUAGE OverloadedStrings, MultilineStrings #-} module Headers where import Data.List (intercalate) import Backends - -data Import = N String | Q String String +import Futhark.Manifest +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString as B +import qualified Data.Char as C +import qualified Data.Map.Strict as M -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 +data Import = N Text | Q Text Text -haskellHeader exports extensions localImports globalImports moduleName subModuleName +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 +ffi = "ForeignFunctionInterface" +duprec = "DuplicateRecordFields" +typefamilies = "TypeFamilyDependencies" +typesynonyms = "LiberalTypeSynonyms" +undecidable = "UndecidableInstances" +applicativedo = "ApplicativeDo" +ctypes = [ N "Foreign.C.Types hiding (CBool)", N "Foreign.C.String", N "Foreign.Ptr" ] +primtypes = [ N "Futhask.PrimTypes" ] +arrays = [ N "Futhask.Array" ] +mcomment t = "\n{-|\n" <> t <> "\n-}\n" +haskellHeader desc doc exports extensions localImports globalImports moduleName subModuleName = (if length extensions > 0 - then "{-# LANGUAGE " ++ intercalate ", " extensions ++ " #-}" + then "{-# LANGUAGE " <> T.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 Multicore = [] -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(..), CUChar(..), CFile(..))" - , N "Foreign.Ptr (Ptr)" ] ++ specific backend ) - -typeClassesHeader backend = haskellHeader - [ "FutharkObject", "FutharkArray" - , "freeFO", "fromFO", "withFO", "wrapFO", "finalizeFO" - , "newFA", "shapeFA", "valuesFA" - , "Input", "Output" - , "fromFuthark", "toFuthark" ] - [ "MultiParamTypeClasses", "FunctionalDependencies", "TypeSynonymInstances" ] - [ Q "Raw" "Raw", N "Fut" ] - [ N "Foreign", Q "Data.Massiv.Array" "M" - , N "Control.Monad.Trans", N "Control.Monad.IO.Class", N "Control.Concurrent" ] - -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", N "System.Mem (performGC)"] + <> mcomment desc + <> "module " + <> moduleName <> (case subModuleName of Nothing -> ""; Just n -> "." <> n) + <> (if length exports > 0 then " (" <> T.intercalate ", " exports <> ")" else "") + <> " where\n" + <> mconcat (map (localImport moduleName) localImports) + <> mconcat (map globalImport globalImports) + <> "\n" + <> doc + <> "\n" -futHeader backend = haskellHeader - [ "FutT", "Fut", "FutIO" - , "runFutIn", "runFutWith", "runFut", "runFutTIn", "runFutTWith", "runFutT" - , "mapFutT", "map2FutT", "pureFut", "unsafeFromFutIO", "unsafeLiftFromIO" ] - [ "RankNTypes", "ExistentialQuantification", "FlexibleInstances", "UndecidableInstances", "TypeFamilies", "MultiParamTypeClasses" ] - [ N "Context", N "Config" ] - [ N "System.IO.Unsafe", N "Control.Monad.Base", N "Control.Monad.Trans", N "Control.Monad.Trans.Control", N "Control.Monad.Identity" ] +exportsHeader name = haskellHeader desc doc [] extensions localImports globalImports name (Nothing) + where + extensions = [] + exports = + [ "module M" + , "module T" + , "module E" + , "module C" + , "module F" ] + localImports = + [ N "Monad as M" + , N "Types as T" + , N "EntryPoints as E" + , N "Conversion as C" ] + globalImports = [N "Futhask.Object as F"] + desc = "Export of common interface" + doc = T.replace "LIB" name $ + """ + -- * Introduction + -- $introduction + -- This Haskell library was generated from a [Futhark](https://www.futhark-lang.org) program by the futhark-haskell bridge [Futhask](https://gitlab.com/Gusten_Isfeldt/futhask). -wrapHeader backend = haskellHeader - [] - [ "RankNTypes" - , "FlexibleInstances" - , "FlexibleContexts" - , "MultiParamTypeClasses" - , "UndecidableInstances" ] - [ Q "Raw" "Raw", N "Context", N "Fut", N "TypeClasses" ] - [ N "Foreign as F", Q "Foreign.Concurrent" "FC", N "Foreign.C" + -- * Interfaces + -- $interfaces + -- @Futhask@ defines two interfaces, either of which may be appropriate for a use case. + + -- ** Raw + -- $rawinterface + -- Defined in the \"LIB.Raw\" module, the raw interface is simply the C-API wrapped in the IO-monad, with no additional safety or convenience. Manual memory management is required and error codes must be handled by the user. + -- This could be useful if working with a small loop where overhead needs to be minimized and manual memory management would be used anyway. + -- Some parts of the C-API are not yet utilized by the wrapped interface and are thus only accessible through the raw interface. + + -- ** Wrapped + -- $wrappedinterface + -- Defined in \"LIB\", the wrapped interface provides a safer and more convenient way to use the Futhark functions. It provides types closer to those used within the futhark program, enables garbage collection of all values, conversion to and from futhark types, passes the context implicitly through a reader style monad, and emits any errors from the context. + -- What the wrapper does NOT prevent, and will result in errors: + -- + -- - Use after free if *manually* finalizing values with `finalizeFO` + -- + -- - Mismatched sizes in arguments + + -- * Types + -- $types + -- For each Futhark type in the manifest some types are defined in the generated library. They are all named based on the Futhark type. Named types just have their name capitalized, and unnamed types like records, sums, and arrays, get a name that describes the type structurally. For clarity the original Futhark type is included in the documentation of each module. + + -- ** Raw + -- $rawtypes + -- \"LIB.Raw.TypeDec\" defines data types that have no constructor and only serve to parameterize the pointers used in the raw C-API. These are used in the raw interface and internally to create the wrapped interface. + + -- ** Wrapped + -- $wrappedtypes + -- \"LIB.TypeDec\" defines the primary types used in the wrapped interface. These data types are wrappers around the raw pointers, and come with reference counters and finalizers. To prevent them from escaping the context to which they belong they are parameterized by a skolem type variable, similar to mutable objects in the @ST@-monad. + + -- ** Native + -- $nativetypes + -- \"LIB.Native.Types\" defines haskell native data types and synomyms that correspond to the wrapped types. These are primarily useful for lighter processing of data going into and coming out of the context through the `Convertible` class. + + -- ** Unpacked + -- $unpackedtypes + -- \"LIB.Unpacked.Types\" defines types unpacked versions of composite types, such as records, record arrays, and sums. They are used to compose and decompose such values from their components through the `FutharkComposite` class. - , Q "Data.Massiv.Array" "M", Q "Data.Massiv.Array.Unsafe" "MU", N "Control.Concurrent" ] + -- * Monad + -- $monad + -- Computations in the wrapped interface are in the @Monad m => FutT c m@ monad + -- and can be run by using the functions in \"LIB.Monad\" + -- which is a version of the general \"Futhask.Monad\" specialized to \"LIB.Context\". + + + """ -typesHeader backend = haskellHeader - [] - [ "RankNTypes", "ExistentialQuantification" - , "MultiParamTypeClasses", "TypeSynonymInstances", "FlexibleInstances" ] - [ Q "Raw" "Raw", N "Wrap", N "TypeClasses" ] - [ Q "Foreign" "F", Q "Data.Massiv.Array" "M" - , Q "Control.Concurrent.MVar" "MV" - , N "Data.Int (Int8, Int16, Int32, Int64)" - , N "Data.Word (Word8, Word16, Word32, Word64)" - , N "Foreign.C.Types (CBool(..), CSize(..), CChar(..), CUChar(..), CFile(..))" - , N "Foreign.Ptr (Ptr)" - , N "Control.DeepSeq (rwhnf)" ] +nativeTypesHeader name = haskellHeader desc doc [] extensions [] globalImports name (Just "Native.Types") + where + extensions = [duprec, typefamilies, applicativedo] + globalImports = primtypes ++ arrays + desc = "Native types that mirror the types in the manifest" + doc = "" +nativeTypeOpsHeader name = haskellHeader desc doc [] extensions [] globalImports name (Just "Native.TypeOps") + where + extensions = [] + globalImports = [] + desc = mcomment "Various instances for generated native types" + doc = "" +rawHeader name = haskellHeader desc doc [] extensions localImports globalImports name (Just "Raw (module C, module E, module T)") + where + extensions = [] + localImports = + [ N "Raw.Context as C" + , N "Raw.EntryPoints as E" + , N "Raw.Types as T"] + globalImports = [] + desc = "export of raw interface" + doc = "" +rawContextHeader name = haskellHeader desc doc [] extensions localImports globalImports name (Just "Raw.Context") + where + extensions = [ffi] + localImports = [] + globalImports = ctypes + desc = "raw context operations" + doc = "" +rawTypesHeader name = haskellHeader desc doc [] extensions localImports globalImports name (Just "Raw.Types (module Dec, module Ops)") + where + extensions = [] + localImports = + [ N "Raw.TypeDec as Dec" + , N "Raw.TypeOps as Ops"] + globalImports = [] + desc = "Reexport of @Raw.TypeDec@ and @Raw.TypeOps@" + doc = "" +rawTypeDecHeader name = haskellHeader desc doc [] extensions localImports globalImports name (Just "Raw.TypeDec") + where + extensions = [ffi] + localImports = [] + globalImports = [] + desc = "raw types" + doc = "" +rawTypeOpsHeader name = haskellHeader desc doc [] extensions localImports globalImports name (Just "Raw.TypeOps") + where + extensions = [ffi] + localImports = + [ Q "Raw.TypeDec" "Raw", Q "Raw.Context" "C" ] + globalImports = ctypes ++ primtypes + desc = "raw type operations" + doc = "" -entriesHeader backend = haskellHeader - [] - [] - [ Q "Raw" "Raw", Q "Context" "C", N "Fut (FutT)", Q "Fut" "Fut" - , 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" ] +rawEntryPointsHeader name = haskellHeader desc doc [] extensions localImports globalImports name (Just "Raw.EntryPoints") + where + extensions = [ffi] + localImports = + [ Q "Raw.Context" "C" + , Q "Raw.TypeDec" "Raw" ] + globalImports = + [ N "Foreign.Ptr", N "Foreign.C.Types(CBool)" ] ++ primtypes + desc = "Raw entry points" + doc = "" -utilsHeader backend = haskellHeader - [] - [ "RankNTypes" - , "FlexibleContexts" - , "FlexibleInstances" - , "MultiParamTypeClasses" - , "UndecidableInstances" ] - [ Q "Raw" "Raw", N "Context", N "Fut", N "TypeClasses", N "Wrap" ] - [ N "Foreign as F", Q "Foreign.Concurrent" "FC", N "Foreign.C" +monadHeader name = haskellHeader desc doc [] extensions localImports globalImports name (Just "Monad") + where + extensions = [] + localImports = + [ N "Context" ] + globalImports = + [ N "Control.Monad.IO.Class", Q "Futhask.Monad" "Futhask" ] + desc = "This module specializes \"Futhask.Monad\" to the \"" <> name <> ".Context\", for the general version see original module" + doc = "" +contextHeader name = haskellHeader desc doc [] extensions localImports globalImports name (Just "Context(Context, mkContext, Futhask.ContextOption(..))") + where + extensions = [typefamilies] + localImports = + [ Q "Raw.Context" "Raw" ] + globalImports = + [ Q "Futhask.Context" "Futhask", N "Foreign.ForeignPtr" ] + desc = "Context for \"" <> name <> "\", for more functions and more general definitions, see \"Futhask.Context\"." + doc = "" +typeDecHeader name = haskellHeader desc doc [] extensions localImports globalImports name (Just "TypeDec") + where + extensions = [] + localImports = + [ Q "Context" "C" + , Q "Raw.TypeDec" "Raw" ] + globalImports = + [ Q "Futhask.Context" "Futhask" + , Q "Foreign.ForeignPtr" "F" ] + desc = "Wrapped types parameterized by a skolem type variable locking them to a context" + doc = "" +typesHeader name = haskellHeader desc doc [] extensions localImports globalImports name (Just "Types(module Dec, module Ops)") + where + extensions = [] + localImports = + [ N "TypeDec as Dec" + , N "TypeOps as Ops" ] + globalImports = [] + desc = "Rexport @TypeDec@ and @TypeOps@" + doc = "" +typeOpsHeader name = haskellHeader desc doc [] extensions localImports globalImports name (Just "TypeOps") + where + extensions = [typefamilies, typesynonyms] + localImports = + [ Q "Context" "C" + , Q "Raw.TypeDec" "Raw" + , Q "Raw.TypeOps" "Raw" + , Q "TypeDec" "Wrapped" + , Q "Unpacked.Types" "Unpacked"] + globalImports = + [ Q "Futhask.Context" "Futhask" + , N "Futhask.Context" + , Q "Futhask.Object" "Futhask" + , N "Futhask.PrimTypes" + , N "Futhask.Array.Rank" + , N "Futhask.Object" + , N "Futhask.Monad" + --, N "Futhask.Object (wrapFO, FutharkObject, FutharkOpaque, FutharkRecord, FutIndexable, FutharkPrimArray', FutharkOpaqueArray')" + , Q "Foreign.ForeignPtr" "F" + , N "Foreign.Storable (peek)" + , N "Foreign.Marshal.Alloc (alloca)"] + desc = "Various instance declarations" + doc = "" +unpackedTypesHeader name = haskellHeader desc doc [] extensions localImports globalImports name (Just "Unpacked.Types") + where + extensions = [duprec] + localImports = + [ Q "TypeDec" "Packed" ] + globalImports = primtypes + desc = "Unpacked types for value composition and decomposition" + doc = "" +entryPointsHeader name = haskellHeader desc doc [] extensions localImports globalImports name (Just "EntryPoints") + where + extensions = [] + localImports = + [ Q "Monad" "M" + , N "Types" + , Q "Raw.EntryPoints" "RawEntry" + , Q "Raw.TypeOps" "Raw" ] + globalImports = + [ N "Control.Monad.IO.Class" + , Q "Futhask.Context" "C" + , Q "Futhask.Object" "O" + , Q "Foreign.Marshal.Alloc" "F" + , Q "Foreign.Storable" "F" + , Q "Foreign.Marshal.Utils" "F"] + ++ primtypes + desc = "This module provides wrapped entry points. The input and output types are intended to mimic the Futhark types as closely as possible, by packing tuple inputs and unpacking tuple outputs internally. The functions are in the general @Monad => FutT c m@ monad, unless any inputs are unique, in which case they will be restricted to the @MonadIO m => FutT c m@ monad. Unique inputs are finalized on use and may no longer be used after." + doc = "" - , Q "Data.Massiv.Array" "M", Q "Data.Massiv.Array.Unsafe" "MU" ] +conversionHeader name = haskellHeader desc doc [] extensions localImports globalImports name (Just "Conversion") + where + extensions = [typefamilies, undecidable, typesynonyms] + localImports = + [ N "Monad" + , N "TypeOps" + , Q "TypeDec" "Futhark" + , Q "Unpacked.Types" "Unpacked" + , Q "Native.Types" "Haskell" + , Q "Raw.TypeOps" "Raw"] + globalImports = + [ N "Futhask.Object" + , N "Futhask.Array as A" + , N "Futhask.Context" + , Q "Foreign.ForeignPtr" "F" + , Q "Foreign.Storable" "F" + , Q "Foreign.Marshal.Array" "F" ] + desc = "Conversion of values to and from Futhark" + doc = "" -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 "Fut as F" ] - [] diff --git a/src/Monad.hs b/src/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Monad.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings, MultilineStrings #-} + +module Monad where +import qualified Futhark.Manifest as FM +import Backends +import CodeGen + +monadBody manifest = + """ + -- *The Monad Transformer + -- | The transformer that passes around the Futhark context. + -- The @c@ parameter is skolem and prevents Futhark values from escaping the monad. + + type FutT c m = Futhask.FutT Context c m + -- **Predefined monads + + + -- | lazy without side effects, no manual memory management possible + type Fut c = Futhask.Fut Context c + + -- | strict with side effects, manual memory management possible + type FutIO c = Futhask.FutIO Context c + + + -- *Running the Transformer + + -- | Runs the transformer in a given context + runFutTIn :: Context -> (forall c. FutT c m a) -> m a + runFutTIn = Futhask.runFutTIn + + -- | Runs the transformer in a context with a list of options + {-# NOINLINE runFutTWith #-} + runFutTWith :: [ContextOption] -> (forall c. FutT c m a) -> m a + runFutTWith = Futhask.runFutTWith + + -- | Runs the transformer with no context options + runFutT :: (forall c. FutT c m a) -> m a + runFutT = runFutTWith [] + + -- | Runs the @Fut@ monad in a given context + runFutIn :: Context -> (forall c. Fut c a) -> a + runFutIn = Futhask.runFutIn + + + -- | Runs the @Fut@ monad with in a context with a list of options + runFutWith :: [ContextOption] -> (forall c. Fut c a) -> a + runFutWith = Futhask.runFutWith + + -- | Runs the @Fut@ monad with no context options + runFut :: (forall c. Fut c a) -> a + runFut = Futhask.runFut + + -- *Misc + + -- | Lifts a futhark operation from the identity monad to any other monad + pureFut :: Monad m => Fut c a -> FutT c m a + pureFut = Futhask.pureFut + + -- | Maps a function to the monad transformer + mapFutT :: (m a -> n b) -> FutT c m a -> FutT c n b + mapFutT = Futhask.mapFutT + + -- | Same as @mapFutT@ but for two arguments + map2FutT :: (m a -> n b -> k c) -> FutT c' m a -> FutT c' n b -> FutT c' k c + map2FutT = Futhask.map2FutT + + -- *Profiling + + -- | Turns on profiling for the argument. + profile :: MonadIO m => FutT c m a -> FutT c m a + profile = Futhask.profile + + -- *Unsafe Lifting + + -- | Declares a @FutIO@ value as pure. The value must not consume any arguments or have side effects. + {-# INLINE unsafeFromFutIO #-} + unsafeFromFutIO :: Monad m => FutIO c a -> FutT c m a + unsafeFromFutIO = Futhask.unsafeFromFutIO + + -- | Wraps a @(Context -> IO a)@ into the generic @FutT c m a@ . Useful for creating new abstractions from the @Raw@ interface functions. Operations should have no external side effects, or the function should be restricted to @MonadIO@. + {-# INLINE unsafeLiftFromIO #-} + unsafeLiftFromIO :: Monad m => (Context -> IO a) -> FutT c m a + unsafeLiftFromIO = Futhask.unsafeLiftFromIO + """