GPipe 2.1.1 → 2.1.2
raw patch · 4 files changed
+48/−27 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- GPipe.cabal +1/−1
- src/Data/SNMap.hs +22/−13
- src/Graphics/GPipe/Internal/Expr.hs +21/−13
CHANGELOG.md view
@@ -1,3 +1,7 @@+### 2.1.2 + +- Fixed bug when nesting while, ifThen, ifThenElse or ifThenElse'. + ### 2.1.1 - Made ifB use ifThenElse' instead to avoid unwanted strictness
GPipe.cabal view
@@ -1,5 +1,5 @@ name: GPipe -version: 2.1.1 +version: 2.1.2 cabal-version: >= 1.8 build-type: Simple author: Tobias Bexelius
src/Data/SNMap.hs view
@@ -6,7 +6,8 @@ runSNMapReaderT, newSNMap, memoize, - memoizeM + memoizeM, + scopedM )where import System.Mem.StableName @@ -15,35 +16,43 @@ import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Trans.Class import System.Mem.Weak (addFinalizer) -import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) import Control.Applicative (Applicative) import Control.Monad.Exception (MonadException, MonadAsyncException) +import Control.Monad.Trans.State.Strict newtype SNMap m a = SNMap (HT.BasicHashTable (StableName (m a)) a) newSNMap :: IO (SNMap m a) newSNMap = SNMap <$> HT.new -memoize :: MonadIO m => SNMap m a -> m a -> m a -memoize (SNMap h) m = do s <- liftIO $ makeStableName $! m - x <- liftIO $ HT.lookup h s - case x of +memoize :: MonadIO m => m (SNMap m a) -> m a -> m a +memoize getter m = do s <- liftIO $ makeStableName $! m + (SNMap h) <- getter + x <- liftIO $ HT.lookup h s + case x of Just a -> return a Nothing -> do a <- m - liftIO $ do - HT.insert h s a - addFinalizer m (HT.delete h s) + (SNMap h') <- getter --Need to redo because of scope + liftIO $ HT.insert h' s a return a -newtype SNMapReaderT a m b = SNMapReaderT (ReaderT (SNMap (SNMapReaderT a m) a) m b) deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadAsyncException) +newtype SNMapReaderT a m b = SNMapReaderT (StateT (SNMap (SNMapReaderT a m) a) m b) deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadAsyncException) runSNMapReaderT :: MonadIO m => SNMapReaderT a m b -> m b runSNMapReaderT (SNMapReaderT m) = do h <- liftIO newSNMap - runReaderT m h + evalStateT m h instance MonadTrans (SNMapReaderT a) where lift = SNMapReaderT . lift memoizeM :: MonadIO m => SNMapReaderT a m a -> SNMapReaderT a m a -memoizeM m = do h <- SNMapReaderT ask - memoize h m +memoizeM = memoize (SNMapReaderT get) + +-- | Run a subcomputation in a scope, where nothing memoized inside will be remembered after +scopedM :: MonadIO m => SNMapReaderT a m x -> SNMapReaderT a m x +scopedM m= do SNMap h <- SNMapReaderT get + save <- liftIO $ HT.toList h + x <- m + h' <- liftIO $ HT.fromList save + SNMapReaderT $ put (SNMap h') + return x
src/Graphics/GPipe/Internal/Expr.hs view
@@ -340,13 +340,17 @@ toBase x ~(a,b,c,d) = ShaderBaseProd (toBase x a) (ShaderBaseProd (toBase x b) (ShaderBaseProd (toBase x c) (toBase x d))) fromBase x (ShaderBaseProd a (ShaderBaseProd b (ShaderBaseProd c d))) = (fromBase x a, fromBase x b, fromBase x c, fromBase x d) --- | Works just like 'ifB', return second argument if first is 'true' otherwise return third argument. The difference from 'ifB' is that it --- might generate more efficient code when a is a compound type (e.g. a tuple or a vector). This is especially true if either of the two branch arguments --- contain a 'while' loop. +-- | Works just like 'ifB', return second argument if first is 'true' otherwise return third argument. +-- +-- The difference from 'ifB' is that it in most cases generate more efficient code when @a@ is a compound type (e.g. a tuple or a vector). +-- For simple types such as @S x Float@, @ifThenElse' == ifB@. ifThenElse' :: forall a x. (ShaderType a x) => S x Bool -> a -> a -> a ifThenElse' b t e = ifThenElse b (const t) (const e) () --- | @ifThenElse c f g x@ will return @f x@ if @c@ evaluates to 'true' or @g x@ otherwise. +-- | @ifThenElse c f g x@ will return @f x@ if @c@ evaluates to 'true' or @g x@ otherwise. +-- +-- In most cases functionally equivalent to 'ifThenElse'' but +-- usually generate smaller shader code since the last argument is not inlined into the two branches, which also would affect implicit derivates (e.g. 'dFdx', 'dFdy' or sampling using @SampleAuto@) ifThenElse :: forall a b x. (ShaderType a x, ShaderType b x) => S x Bool -> (a -> b) -> (a -> b) -> a -> b ifThenElse c t e i = fromBase x $ ifThenElse_ c (toBase x . t . fromBase x) (toBase x . e . fromBase x) (toBase x i) where @@ -359,14 +363,17 @@ void $ evalStateT (shaderbaseAssign a) aDecls decls <- execWriterT $ shaderbaseDeclare (toBase x (undefined :: b)) tellIf boolStr - void $ evalStateT (shaderbaseAssign $ thn lifted) decls + scopedM $ void $ evalStateT (shaderbaseAssign $ thn lifted) decls T.lift $ T.lift $ tell "} else {\n" - void $ evalStateT (shaderbaseAssign $ els lifted) decls + scopedM $ void $ evalStateT (shaderbaseAssign $ els lifted) decls T.lift $ T.lift $ tell "}\n" return decls in evalState (runReaderT (shaderbaseReturn (toBase x (undefined :: b))) ifM) 0 --- | @ifThen c f x@ will return @f x@ if @c@ evaluates to 'true' or @x@ otherwise. +-- | @ifThen c f x@ will return @f x@ if @c@ evaluates to 'true' or @x@ otherwise. +-- +-- In most cases functionally equivalent to 'ifThenElse'' but +-- usually generate smaller shader code since the last argument is not inlined into the two branches, which also would affect implicit derivates (e.g. 'dFdx', 'dFdy' or sampling using @SampleAuto@) ifThen :: forall a x. (ShaderType a x) => S x Bool -> (a -> a) -> a -> a ifThen c t i = fromBase x $ ifThen_ c (toBase x . t . fromBase x) (toBase x i) where @@ -378,7 +385,7 @@ (lifted, decls) <- runWriterT $ shaderbaseDeclare (toBase x (undefined :: a)) void $ evalStateT (shaderbaseAssign a) decls tellIf boolStr - void $ evalStateT (shaderbaseAssign $ thn lifted) decls + scopedM $ void $ evalStateT (shaderbaseAssign $ thn lifted) decls T.lift $ T.lift $ tell "}\n" return decls in evalState (runReaderT (shaderbaseReturn (toBase x (undefined :: a))) ifM) 0 @@ -397,11 +404,12 @@ (lifted, decls) <- runWriterT $ shaderbaseDeclare (toBase x (undefined :: a)) void $ evalStateT (shaderbaseAssign a) decls boolDecl <- tellAssignment STypeBool (unS $ bool a) - T.lift $ T.lift $ tell $ mconcat ["while(", boolDecl, "){\n" ] - let looped = loopF lifted - void $ evalStateT (shaderbaseAssign looped) decls - loopedBoolStr <- unS $ bool looped - tellAssignment' boolDecl loopedBoolStr + T.lift $ T.lift $ tell $ mconcat ["while(", boolDecl, "){\n" ] + let looped = loopF lifted + scopedM $ do + void $ evalStateT (shaderbaseAssign looped) decls + loopedBoolStr <- unS $ bool looped + tellAssignment' boolDecl loopedBoolStr T.lift $ T.lift $ tell "}\n" return decls in evalState (runReaderT (shaderbaseReturn (toBase x (undefined :: a))) whileM) 0