packages feed

futhask 0.1.0 → 0.2.0

raw patch · 8 files changed

+280/−120 lines, 8 files

Files

ChangeLog.md view
@@ -1,3 +1,4 @@ # Changelog for futhask  ## Unreleased changes+Change in the name of the Monad from `FT` to `Fut`. This is a breaking change, but in principle a simple search and replace should fix it. The motivation for the change is both that it is more descriptive, and the introduction of the transformer. `FutT` simply looks better then `FTT`, especially in names using CamelCase. The original name `FT` was inspired by `ST`, since they both use rigid type variables for similar purposes.
README.md view
@@ -29,38 +29,82 @@     extra-libraries: cuda cudart nvrtc  ### Dependencies-`massiv` is required for all backends.+`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.  ## 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, returning tuples instead of writing to pointers.  ### Context Generation     getContext :: [ContextOption] -> IO Context  Available context options will depend on backend used. -### The FT monad-To make the wrappers safe, and reduce clutter from explicitly passing around the context, the FT monad is introduced. The FT monad is an environment (Reader) monad that implicitly passes the context around as necessary. Like the ST monad, the FT monad is parameterised by a rigid type variable to prevent references to the context from escaping the monad.+### 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 -    runFTIn :: Context -> (forall c. FT c a) -> a+    runFutIn :: Context -> (forall c. Fut c a) -> a  is used. Additionally -    runFTWith :: [ContextOption] -> (forall c. FT c a) -> a-    runFT :: (forall c. FT c a) -> a+    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++are defined, but entry-points are in the general `Monad m => FutT c m`.++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++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++#### 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 ++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 :: ho -> FT c (fo c) +        toFuthark :: Monad m => ho -> FutT c m (fo c)       class Output fo ho where-        fromFuthark :: fo c -> FT c ho+        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 ()++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 ()++can be used. `addReferenceFO` increments the reference counter of the object and `finalizeFO` will just decrement this counter until it's `0`.++
app/Main.hs view
@@ -24,10 +24,11 @@          [a, b, c, d] -> return args          _            -> error "futhask takes four arguments:\n - backend (c, opencl, cuda)\n - Futhark header file\n - Haskell source directory\n - module name"     backend <- case backendS of-        "c"      -> return C-        "opencl" -> return OpenCL-        "cuda"   -> return Cuda-        _        -> error $ "unknown backend: " ++ backendS ++ "\n  available backends: c, opencl, cuda"+        "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)@@ -38,7 +39,7 @@         , (Just "TypeClasses", typeClassesHeader, typeClassesBody)         , (Just "Context", contextHeader, contextBody)         , (Just "Config", configHeader, configBody backend)-        , (Just "FT", fTHeader, fTBody)+        , (Just "Fut", futHeader, futBody)         , (Just "Wrap", wrapHeader, wrapBody)         , (Just "Utils", utilsHeader, utilsBody)         , (Nothing, exportsHeader, "") ]
futhask.cabal view
@@ -1,7 +1,7 @@ cabal-version: 1.12  name:           futhask-version:        0.1.0+version:        0.2.0 synopsis:       Generate Haskell wrappers for Futhark libraries description:    Please see the README on GitLab at <https://gitlab.com/Gusten_Isfeldt/futhask#futhask> category:       FFI Tools
src/Backends.hs view
@@ -1,3 +1,3 @@ module Backends where -data Backend = C | OpenCL | Cuda+data Backend = C | OpenCL | Cuda | Multicore
src/CodeBodies.hs view
@@ -7,12 +7,27 @@  typeClassesBody = [r| class FutharkObject wrapped raw | wrapped -> raw, raw -> wrapped where-    wrapFO :: ForeignPtr raw -> wrapped c+    wrapFO :: MVar Int -> ForeignPtr raw -> wrapped c     freeFO :: Ptr Raw.Futhark_context -> Ptr raw -> IO Int-    withFO :: wrapped c -> (Ptr raw -> IO b) -> IO b+    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 @@ -22,10 +37,10 @@         valuesFA :: Ptr Raw.Futhark_context -> Ptr rawArray -> Ptr element -> IO Int   class Input fo ho where-    toFuthark :: ho -> FT c (fo c)+    toFuthark :: Monad m => ho -> FutT c m (fo c)  class Output fo ho where-    fromFuthark :: fo c -> FT c ho+    fromFuthark :: Monad m => fo c -> FutT c m ho  |] @@ -33,47 +48,69 @@ 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+    (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-    (Device s)           -> withCString s $ Raw.context_config_set_device   config-    (Platform s)         -> withCString s $ Raw.context_config_set_platform config-    (LoadProgram s)      -> withCString s $ Raw.context_config_load_program_from config -    (LoadBinary s)       -> withCString s $ Raw.context_config_load_binary_from  config -    (DumpBinary s)       -> withCString s $ Raw.context_config_dump_binary_to    config -    (DefaultGroupSize s) -> Raw.context_config_set_default_group_size config s-    (DefaultGroupNum n)  -> Raw.context_config_set_default_num_groups config n-    (DefaultTileSize s)  -> Raw.context_config_set_default_tile_size  config s-    (DefaultThreshold n) -> Raw.context_config_set_default_threshold  config n-    (Size name s)        -> withCString name $ \n -> Raw.context_config_set_size config n s-                                           >>= \code -> if code == 0-                                                           then return ()-                                                           else error "invalid size"+    (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|@@ -81,6 +118,7 @@     = NvrtcOptions [String]     | Debug Int     | Log Int+    | Cache String     | Device String     | LoadProgram String     | DumpProgram String@@ -89,26 +127,29 @@     | 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-    (Device s)           -> withCString s $ Raw.context_config_set_device   config-    (LoadProgram s)      -> withCString s $ Raw.context_config_load_program_from config -    (DumpProgram s)      -> withCString s $ Raw.context_config_dump_program_to   config -    (LoadPtx s)          -> withCString s $ Raw.context_config_load_ptx_from     config -    (DumpPtx s)          -> withCString s $ Raw.context_config_dump_ptx_to       config -    (DefaultGroupSize s) -> Raw.context_config_set_default_group_size config s-    (DefaultGroupNum n)  -> Raw.context_config_set_default_num_groups config n-    (DefaultTileSize s)  -> Raw.context_config_set_default_tile_size  config s-    (DefaultThreshold n) -> Raw.context_config_set_default_threshold  config n-    (Size name s)        -> withCString name $ \n -> Raw.context_config_set_size config n s-                                           >>= \code -> if code == 0-                                                           then return ()-                                                           else error "invalid size"+    (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|@@ -119,18 +160,18 @@     config <- Raw.context_config_new     mapM_ (setOption config) options     context <- Raw.context_new config-    Raw.context_config_free config-    childCount <- S.newMVar 0+    childCount <- newMVar 0     fmap (Context childCount)         $ FC.newForeignPtr context -        $ (forkIO $ freeContext childCount context)+        $ (forkIO $ freeContext childCount config context)         >> return () -freeContext childCount pointer +freeContext childCount config context      = readMVar childCount >>= \n      -> if n == 0 -        then Raw.context_free pointer -        else yield >> freeContext childCount pointer+        then do Raw.context_free context+                Raw.context_config_free config+        else yield >> freeContext childCount config context  inContext (Context _ fp) = withForeignPtr fp @@ -157,58 +198,118 @@ inContextWithError :: Context -> (Ptr Raw.Futhark_context -> IO Int) -> IO () inContextWithError context f = do     code <- attempt-    if code == 0 -        then success-        else do+    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-    where-        attempt = inContext context f-        success = return ()-        failure = getError context+        unknownError = failure  |]  -fTBody = [r|-newtype FT c a = FT (Context -> a)+futBody = [r| -instance Functor (FT c) where-    fmap f (FT a) = FT (f.a)+newtype FutT c m a = FutT (Context -> m a) -instance Applicative (FT c) where-    pure a = FT (\_ -> a)-    (<*>) (FT a) (FT b) = FT (\c -> a c $ b c)+instance MonadTrans (FutT c) where+    lift a = FutT (\_ -> a)+    {-# INLINEABLE lift #-} -instance Monad (FT c) where-    return = pure -    (>>=) (FT a) f = FT (\c -> (\(FT b) -> b c) $ f $ a c)+instance Functor m => Functor (FutT c m) where+    fmap f (FutT a) = FutT (fmap f.a)+    {-# INLINEABLE fmap #-} -runFTIn :: Context -> (forall c. FT c a) -> a-runFTIn context (FT a) = a context+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 (>>=) #-} -runFTWith :: [ContextOption] -> (forall c. FT c a) -> a-runFTWith options a -    = unsafePerformIO -    $ getContext options >>= \c -> return $ runFTIn c a -runFT = runFTWith []+instance (MonadBase b m) => MonadBase b (FutT c m) where+    liftBase = liftBaseDefault+    {-# INLINEABLE liftBase #-} -unsafeLiftFromIO :: (Context -> IO a) -> FT c a-unsafeLiftFromIO a = FT (\c -> unsafePerformIO $ a c)+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 context@(Context childCount pointer) rawObject -    =  S.modifyMVar_ childCount (return.(+1))-    >> (fmap wrapFO $ FC.newForeignPtr rawObject freeCall)++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)-                  >> S.modifyMVar_ childCount (return.(+(-1)))+                  >> modifyMVar_ childCount (\cc -> return $! (cc-1))  peekFree p = peek p >>= \v -> free p >> return v peekFreeWrapIn context rawP @@ -284,10 +385,10 @@       -> inContext context $ \c       -> withFO array $ \aP       -> do-          syncContext context           shape <- shapeFA c aP           pointer <- mallocForeignPtrArray $ M.totalElem shape-          withForeignPtr pointer $ valuesFA c aP+          withForeignPtr pointer $ valuesFA c aP +          syncContext context           return $ M.resize' shape                  $ MU.unsafeArrayFromForeignPtr0 M.Seq pointer                  $ M.Sz1 (M.totalElem shape)
src/Conversion.hs view
@@ -4,6 +4,7 @@ import Data.List (intercalate, partition, lookup) import Data.Char (toUpper) import Text.ParserCombinators.ReadP+import Debug.Trace  data HeaderItem      = Preproc String@@ -12,6 +13,8 @@     | 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;,()"@@ -34,7 +37,7 @@        >> return (Fun tn args)  -readHeaderItem = skipSpaces >> readPreproc <++ readComment <++ readOnelineComment <++ readFun <++ readVar+readHeaderItem = skipSpaces >> readExtern <++ readExtern2 <++ readPreproc <++ readComment <++ readOnelineComment <++ readFun <++ readVar readHeader fn = fmap (fst . head              . (readP_to_S $ many readHeaderItem >>= \his                           -> skipSpaces >> eof >> return his)) @@ -45,6 +48,7 @@     , ("float", "Float")     , ("double", "Double")     , ("char", "CChar")+    , ("unsigned char", "CUChar")     , ("bool", "CBool")     , ("void", "()")     , ("int8_t" , "Int8")@@ -56,6 +60,7 @@     , ("uint32_t", "Word32")     , ("uint64_t", "Word64")     , ("size_t", "CSize")+    , ("FILE", "CFile")     , ("cl_mem", "CLMem")     , ("cl_command_queue", "CLCommandQueue")     , ("CUdeviceptr", "DevicePtr ()") ]@@ -81,7 +86,7 @@      in (intercalate "(" $ replicate pn "Ptr ")       ++ (if head ts == "struct"              then capitalize $ ts !! 1-            else (case lookup (head ts) varTable of +            else (case lookup (intercalate " " ts) varTable of                      Just s -> s;                      Nothing -> error $ "type \'" ++ s ++ "\' not found";))      ++ replicate (pn-1) ')'@@ -122,11 +127,11 @@                      ++ "  shapeFA  = to" ++ show dim ++ "d Raw.shape_" ++ sn ++ "\n"                      ++ "  newFA    = from" ++ show dim ++ "d Raw.new_" ++ sn ++ "\n"                      ++ "  valuesFA = Raw.values_" ++ sn ++ "\n"-          objectString = "\nnewtype " ++ cn ++ " c = " ++ cn ++ " (F.ForeignPtr Raw." ++ rn ++ ")\n"+          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"-                      ++ "  withFO (" ++ cn ++ " fp) = F.withForeignPtr fp\n"+                      ++ "  fromFO (" ++ cn ++ " rc fp) = (rc, fp)\n"           nfdataString = "instance NFData (" ++ cn ++" c) where rnf = rwhnf"  instanceDeclarations _ = ""@@ -138,10 +143,11 @@         ts = dropWhile (=="const") $ words $ takeWhile (/='*') s      in if head ts == "struct"              then capitalize (drop 8 $ ts !! 1) ++ " c"-            else (case lookup (head ts) varTable of +            else (case lookup (intercalate " " ts) varTable of                      Just s -> s; -                    Nothing -> error $ "type " ++ s ++ "not found";)+                    Nothing -> error $ (trace (show ts)) "type " ++ s ++ "not found";) + entryCall (Fun (_, n) args)      = if isEntry          then "\n" ++ typeDeclaration ++ input ++ preCall ++ call ++ postCall@@ -153,10 +159,10 @@         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  :: " +        typeDeclaration = en ++ "\n  :: Monad m \n  => "                         ++ concatMap (\i -> haskellType' (fst i) ++ "\n  -> " ) inArgs-                       ++ "FT c " ++ wrapIfNotOneWord (intercalate ", " $ map (\o -> haskellType' $ fst o) outArgs) ++ "\n"-        input = unwords (en : map snd inArgs) ++ "\n  =  FT.unsafeLiftFromIO $ \\context\n  -> "+                       ++ "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
src/Headers.hs view
@@ -22,6 +22,7 @@     ++ concatMap globalImport globalImports  specific C = []+specific Multicore = [] specific OpenCL = [N "Control.Parallel.OpenCL (CLMem, CLCommandQueue)"] specific Cuda = [N "Foreign.CUDA.Ptr(DevicePtr(..))"] @@ -31,17 +32,19 @@     []      ( [ N "Data.Int (Int8, Int16, Int32, Int64)"       , N "Data.Word (Word8, Word16, Word32, Word64)"-      , N "Foreign.C.Types (CBool(..), CSize(..), CChar(..))"+      , N "Foreign.C.Types (CBool(..), CSize(..), CChar(..), CUChar(..), CFile(..))"       , N "Foreign.Ptr (Ptr)" ] ++ specific backend )  typeClassesHeader backend = haskellHeader     [ "FutharkObject", "FutharkArray"-    , "freeFO", "withFO", "wrapFO", "newFA", "shapeFA", "valuesFA"+    , "freeFO", "fromFO", "withFO", "wrapFO", "finalizeFO"+    , "newFA", "shapeFA", "valuesFA"     , "Input", "Output"     , "fromFuthark", "toFuthark" ]     [ "MultiParamTypeClasses", "FunctionalDependencies", "TypeSynonymInstances" ]-    [ Q "Raw" "Raw", N "FT" ] -    [ N "Foreign", Q "Data.Massiv.Array" "M" ]+    [ 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     []@@ -53,24 +56,27 @@     []     []     [Q "Raw" "Raw", N "Config" ]-    [N "Foreign as F", Q "Foreign.Concurrent" "FC", N "Foreign.C", N "Control.Concurrent", Q "Control.Concurrent.MVar.Strict" "S", N "System.Mem (performGC)"]+    [N "Foreign as F", Q "Foreign.Concurrent" "FC", N "Foreign.C", N "Control.Concurrent", N "System.Mem (performGC)"] -fTHeader backend = haskellHeader-    [ "FT", "runFTIn", "runFTWith", "runFT", "unsafeLiftFromIO" ]-    [ "RankNTypes", "ExistentialQuantification" ]+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 "System.IO.Unsafe", N "Control.Monad.Base", N "Control.Monad.Trans", N "Control.Monad.Trans.Control", N "Control.Monad.Identity" ]  wrapHeader backend = haskellHeader     []     [ "RankNTypes"     , "FlexibleInstances"+    , "FlexibleContexts"     , "MultiParamTypeClasses"     , "UndecidableInstances" ]-    [ Q "Raw" "Raw", N "Context", N "FT", N "TypeClasses" ]+    [ Q "Raw" "Raw", N "Context", N "Fut", N "TypeClasses" ]     [ N "Foreign as F", Q "Foreign.Concurrent" "FC", N "Foreign.C" -    , Q "Data.Massiv.Array" "M", Q "Data.Massiv.Array.Unsafe" "MU", Q "Control.Concurrent.MVar.Strict" "S" ]+    , Q "Data.Massiv.Array" "M", Q "Data.Massiv.Array.Unsafe" "MU", N "Control.Concurrent" ]  typesHeader backend = haskellHeader     []@@ -78,29 +84,30 @@     , "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(..))"+    , N "Foreign.C.Types (CBool(..), CSize(..), CChar(..), CUChar(..), CFile(..))"     , N "Foreign.Ptr (Ptr)"     , N "Control.DeepSeq (rwhnf)" ] -entriesHeader backend = haskellHeader+entriesHeader backend = haskellHeader      []     []-    [ Q "Raw" "Raw", Q "Context" "C", N "FT (FT)", Q "FT" "FT"+    [ 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" ] --utilsHeader backend =haskellHeader+utilsHeader backend = haskellHeader     []     [ "RankNTypes"+    , "FlexibleContexts"     , "FlexibleInstances"     , "MultiParamTypeClasses"     , "UndecidableInstances" ]-    [ Q "Raw" "Raw", N "Context", N "FT", N "TypeClasses", N "Wrap" ]+    [ Q "Raw" "Raw", N "Context", N "Fut", N "TypeClasses", N "Wrap" ]     [ N "Foreign as F", Q "Foreign.Concurrent" "FC", N "Foreign.C"      , Q "Data.Massiv.Array" "M", Q "Data.Massiv.Array.Unsafe" "MU" ]@@ -112,5 +119,5 @@     , N "Config as F hiding (setOption)"     , N "TypeClasses as F hiding (FutharkObject, FutharkArray)"     , N "Utils as F"-    , N "FT as F" ]+    , N "Fut as F" ]     []