From 315d96fb6f76985ec9269a434039f3afca983d5a Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Thu, 30 May 2019 00:09:21 -0400 Subject: Factored gpu-backend out of RingBuffer, wrote vector-backend. --- GPURing.hs | 46 +++++++++++++++++++++ MeshSketch.hs | 9 +++-- PointPrimitiveRing.hs | 109 -------------------------------------------------- RingBuffer.hs | 70 ++++++++++++++++++++++++++++++++ VectorRing.hs | 17 ++++++++ 5 files changed, 138 insertions(+), 113 deletions(-) create mode 100644 GPURing.hs delete mode 100644 PointPrimitiveRing.hs create mode 100644 RingBuffer.hs create mode 100644 VectorRing.hs diff --git a/GPURing.hs b/GPURing.hs new file mode 100644 index 0000000..d5f46af --- /dev/null +++ b/GPURing.hs @@ -0,0 +1,46 @@ +module GPURing where + +import Control.Monad.Writer +import Data.Data +import Data.Dependent.Sum +import Data.Function +import Data.Typeable + +import AttributeData +import RingBuffer +import MaskableStream + +import LambdaCube.GL as LC hiding (updateBuffer) +import LambdaCube.GL.Data hiding (updateBuffer) -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer) +import LambdaCube.GL.Mesh as LC +import LambdaCube.GL.Type +import LambdaCube.IR as LC +import LambdaCube.GL.Util +import LambdaCube.GL.Input.Type +import LambdaCube.GL.Input hiding (createObjectCommands) + + +-- | Typical usage: +-- +-- > ringBuffer <- newRing capacity (VectorRing.new capacity) +type Update keys = (keys -> Writer [DSum AttributeKey GLUniformValue] ()) + +new :: Data keys => GLStorage -> (String -> String) -> Int -> IO (TargetBuffer (Update keys)) +new storage toAttr sz = fix $ \retProxy -> do + let paramProxy = paramProxy' retProxy + where paramProxy' :: io (targetbuffer (keys -> writer)) -> Proxy keys + paramProxy' _ = Proxy + let ps = fieldParameters paramProxy toAttr + putStrLn $ "Ring params: " ++ show ps + gd0 <- uploadDynamicBuffer sz ps + let gd = gd0 { dPrimitive = LineStrip } + Just keys <- return $ lookupAttrKeys (lookupAttributeKey gd . toAttr) + obj <- addToObjectArray storage "Points" [] gd + -- readIORef (objCommands obj) >>= mapM_ print + return TargetBuffer + { syncBuffer = \mask -> do updateCommands storage obj mask + return () + , updateBuffer = \i u -> do updateAttributes i $ u keys + return () + } + diff --git a/MeshSketch.hs b/MeshSketch.hs index d598bbd..8660119 100644 --- a/MeshSketch.hs +++ b/MeshSketch.hs @@ -59,7 +59,8 @@ import LoadMesh import InfinitePlane import MtlParser (ObjMaterial(..)) import Matrix -import PointPrimitiveRing +import GPURing as GPU +import RingBuffer import MaskableStream (AttributeKey,(@<-)) import SmallRing @@ -103,7 +104,7 @@ data State = State , stSkybox :: IORef Int , stSkyTexture :: IORef TextureCubeData , stDragFrom :: IORef (Maybe (Vector Float,Camera)) - , stRingBuffer :: Ring RingPoint + , stRingBuffer :: RingBuffer (GPU.Update RingPoint) , stPenDown :: IORef Bool , stPlane :: IORef (Maybe Plane) , stDragPlane :: IORef (Maybe (Vector Float,Plane)) @@ -204,7 +205,7 @@ uploadState obj glarea storage = do -- grid plane uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" [] - ring <- newRing storage 100 ringPointAttr + ring <- newRing 100 (GPU.new storage ringPointAttr 100) -- setup FrameClock w <- toWidget glarea @@ -298,7 +299,7 @@ setUniforms gl storage st = do "CameraPosition" @= return (pos :: Vector Float) "ViewProjection" @= return (mvp :: Matrix Float) "PlaneModel" @= return planeModel - updateRingUniforms storage (stRingBuffer st) + -- updateRingUniforms storage (stRingBuffer st) data MeshSketch = MeshSketch { mmWidget :: GLArea diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs deleted file mode 100644 index d4fafae..0000000 --- a/PointPrimitiveRing.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE LambdaCase, RecordWildCards, DataKinds #-} -module PointPrimitiveRing where - -import Control.Monad -import Control.Monad.Writer -import Data.Data -import Data.Dependent.Sum -import Data.Foldable -import Data.Function -import Data.Int -import Data.IORef -import Data.Maybe -import Data.Some -import Data.Word -import qualified Data.Map.Strict as Map -import qualified Data.Vector as V - ;import Data.Vector as V ((!),(//)) -import Foreign.C.Types (CPtrdiff) -import Foreign.Marshal -import Foreign.Ptr -import Foreign.Storable - -import LambdaCube.GL as LC -import LambdaCube.GL.Data -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer) -import LambdaCube.GL.Mesh as LC -import LambdaCube.GL.Type -import LambdaCube.IR as LC -import LambdaCube.GL.Util -import LambdaCube.GL.Input.Type -import LambdaCube.GL.Input hiding (createObjectCommands) - -import AttributeData - --- import Graphics.GL.Core33 - -import MaskableStream - -data Ring keys = Ring - { rBufferObject :: Buffer - , rStorage :: GLStorage - , rObject :: Object - , rSize :: IORef Int -- Current count of vertices in the ring buffer. - , rBack :: IORef Int -- Where next vertex will be added. - , ringCapacity :: Int -- Maximum number of vertices in buffer. - , rKeys :: keys - } - -newRing :: Data keys => GLStorage -> Int -> (String -> String) -> IO (Ring keys) -newRing storage sz toAttr = fix $ \retProxy -> do - let paramProxy = paramProxy' retProxy - where paramProxy' :: io (ring keys) -> Proxy keys - paramProxy' _ = Proxy - startRef <- newIORef 0 - sizeRef <- newIORef 0 - let ps = fieldParameters paramProxy toAttr - putStrLn $ "Ring params: " ++ show ps - gd0 <- uploadDynamicBuffer sz ps - let gd = gd0 { dPrimitive = LineStrip } - Just keys <- return $ lookupAttrKeys (lookupAttributeKey gd . toAttr) - obj <- addToObjectArray storage "Points" [] gd - readIORef (objCommands obj) >>= mapM_ print - let r = Ring - { rBufferObject = streamBuffer $ head $ Map.elems (dStreams gd) - , rStorage = storage - , rObject = obj - , rSize = sizeRef - , rBack = startRef - , ringCapacity = sz - , rKeys = keys - } - updateRingCommands r - return r - -clearRing :: Ring keys -> IO () -clearRing r = do - writeIORef (rBack r) 0 - writeIORef (rSize r) 0 - updateRingCommands r - -updateRingCommands :: Ring keys -> IO () -updateRingCommands r = do - back <- fromIntegral <$> readIORef (rBack r) - size <- fromIntegral <$> readIORef (rSize r) - let mask 0 = [] - mask cnt - | cnt==size = [(0,cnt)] - | otherwise = case cnt + back - size of - front | front > cnt -> [(front - cnt,size)] - | otherwise -> [(0,back), (front,cnt - front)] - updateCommands (rStorage r) (rObject r) mask - -- readIORef (objCommands $ rObject r) >>= mapM_ print - return () - -pushBack :: Ring keys -> (keys -> Writer [DSum AttributeKey GLUniformValue] a) -> IO () -pushBack r attrs = do - back <- readIORef $ rBack r - writeIORef (rBack r) (mod (back + 1) (ringCapacity r)) - updateAttributes back $ attrs (rKeys r) - sz <- readIORef (rSize r) - when (sz < ringCapacity r) $ writeIORef (rSize r) (sz + 1) - updateRingCommands r - -updateBack :: Ring keys -> (keys -> Writer [DSum AttributeKey GLUniformValue] a) -> IO () -updateBack r attrs = do - back <- readIORef $ rBack r - updateAttributes (mod (back - 1) (ringCapacity r)) $ attrs (rKeys r) - -updateRingUniforms :: GLStorage -> Ring keys -> IO () -updateRingUniforms _ _ = return () diff --git a/RingBuffer.hs b/RingBuffer.hs new file mode 100644 index 0000000..b2779d7 --- /dev/null +++ b/RingBuffer.hs @@ -0,0 +1,70 @@ +module RingBuffer where + +import Control.Monad +import Data.Int +import Data.IORef + +data TargetBuffer u = TargetBuffer + { -- | Called whenever the rBack or rSize changes. The purpose is so that + -- some other state, such as an OpenGL vertex buffer object, can remain in + -- sync. + syncBuffer :: (Int32 -> [(Int32,Int32)]) -> IO () + -- | This updates the data associated with a particular index (usually + -- rBack). The update specification /u/ may be a value or a set of + -- key-value pairs or whatever is most convenient way to instruct the + -- target representation to update itself. + , updateBuffer :: Int -> u -> IO () + } + +data RingBuffer u = RingBuffer + { rBack :: IORef Int + , rSize :: IORef Int + , ringCapacity :: Int + , rBuffer :: TargetBuffer u + } + +newRing :: Int -> IO (TargetBuffer u) -> IO (RingBuffer u) +newRing sz newBuffer = do + backRef <- newIORef 0 + sizeRef <- newIORef 0 + b <- newBuffer + let r = RingBuffer + { rBack = backRef + , rSize = sizeRef + , ringCapacity = sz + , rBuffer = b + } + syncRing r + return r + +syncRing :: RingBuffer u -> IO () +syncRing r = do + size <- fromIntegral <$> readIORef (rSize r) + back <- fromIntegral <$> readIORef (rBack r) + let mask 0 = [] + mask cnt + | cnt==size = [(0,cnt)] + | otherwise = case cnt + back - size of + front | front > cnt -> [(front - cnt,size)] + | otherwise -> [(0,back), (front,cnt - front)] + syncBuffer (rBuffer r) mask + +clearRing :: RingBuffer u -> IO () +clearRing r = do + writeIORef (rBack r) 0 + writeIORef (rSize r) 0 + syncRing r + +pushBack :: RingBuffer u -> u -> IO () +pushBack r upd = do + back <- readIORef $ rBack r + writeIORef (rBack r) (mod (back + 1) (ringCapacity r)) + updateBuffer (rBuffer r) back upd + sz <- readIORef (rSize r) + when (sz < ringCapacity r) $ writeIORef (rSize r) (sz + 1) + syncRing r + +updateBack :: RingBuffer u -> u -> IO () +updateBack r upd = do + back <- readIORef $ rBack r + updateBuffer (rBuffer r) back upd diff --git a/VectorRing.hs b/VectorRing.hs new file mode 100644 index 0000000..2ddac72 --- /dev/null +++ b/VectorRing.hs @@ -0,0 +1,17 @@ +module VectorRing where + +import Data.Vector.Unboxed.Mutable +import RingBuffer + +-- | Typical usage: +-- +-- > ringBuffer <- newRing capacity (VectorRing.new capacity) +new :: Unbox a => Int -> IO (TargetBuffer a) +new sz = do + v <- unsafeNew sz + return () :: IO () + return TargetBuffer + { syncBuffer = \_ -> return () + , updateBuffer = \i u -> write v i u + } + -- cgit v1.2.3