From fbb54c463cfd5171a582bb3d9668321d9d450f87 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 18 May 2019 21:15:21 -0400 Subject: Factored lambdacube patch module from ring buffer. --- MaskableStream.hs | 199 ++++++++++++++++++++++++++++++++++++++++++++++++++ PointPrimitiveRing.hs | 172 +++---------------------------------------- 2 files changed, 210 insertions(+), 161 deletions(-) create mode 100644 MaskableStream.hs diff --git a/MaskableStream.hs b/MaskableStream.hs new file mode 100644 index 0000000..c023998 --- /dev/null +++ b/MaskableStream.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE LambdaCase, RecordWildCards #-} + +-- TODO: Formulate this module as a patch against lambdacube-gl. + +module MaskableStream where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Foldable +import Data.Int +import Data.IORef +import Data.Maybe +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 Graphics.GL.Core33 + + +-- based on addMeshToObjectArray +addToObjectArray :: GLStorage + -> String -- ^ Slot name for a PrimitiveStream. + -> [String] -- ^ Uniform names. IORefs will be put in 'objUniSetup'. + -> GPUData + -> IO Object +addToObjectArray input slotName objUniNames (GPUData prim streams indices _) = do + let ObjectArraySchema _ slotStreams = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName) + $ Map.lookup slotName $! objectArrays $! schema input + addObject input slotName prim indices (Map.intersection streams slotStreams) objUniNames + +setUniformCommand :: (String -> GLUniform) + -> (String,GLint) + -> GLObjectCommand +setUniformCommand ulookup (n,i) = GLSetUniform i (ulookup n) + +bindTextureCommand :: (String -> IORef GLint) + -> (String -> GLUniform) + -> String + -> GLObjectCommand +bindTextureCommand tlookup ulookup n = GLBindTexture (inputTypeToTextureTarget $ uniInputType u) (tlookup n) u + where + u = ulookup n + uniInputType (GLTypedUniform ty _) = unwitnessType ty + uniInputType (GLUniform r) = objectType r + +setVertexAttribCommmand :: (t -> Stream Buffer) -> (GLuint, t) -> GLObjectCommand +setVertexAttribCommmand alookup (i,name) = case alookup name of + Stream ty (Buffer arrs bo) arrIdx start len -> mkAttrCmd i bo n (arrayTypeToGLType arrType) (intPtrToPtr $! offset) + where + (n, mkAttrCmd) = classifyStreamType ty + ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx + offset = fromIntegral (arrOffs + start * fromIntegral n * sizeOfArrayType arrType) + + -- constant generic attribute + constAttr -> GLSetVertexAttrib i constAttr + + +lookupOrLookup :: (Ord k, Show k) => String -> Map.Map k a -> Map.Map k a -> k -> a +lookupOrLookup callsite objUnis topUnis n = Map.findWithDefault (topUni n) n objUnis + where + topUni n = Map.findWithDefault (error $ "internal error ("++callsite++"): " ++ show n) n topUnis + +classifyStreamType :: StreamType -> ( GLint + , GLuint -> GLuint -> GLint -> GLenum -> Ptr () -> GLObjectCommand) +classifyStreamType = \case + Attribute_Word -> ( 1 , GLSetVertexAttribIArray ) + Attribute_V2U -> ( 2 , GLSetVertexAttribIArray ) + Attribute_V3U -> ( 3 , GLSetVertexAttribIArray ) + Attribute_V4U -> ( 4 , GLSetVertexAttribIArray ) + Attribute_Int -> ( 1 , GLSetVertexAttribIArray ) + Attribute_V2I -> ( 2 , GLSetVertexAttribIArray ) + Attribute_V3I -> ( 3 , GLSetVertexAttribIArray ) + Attribute_V4I -> ( 4 , GLSetVertexAttribIArray ) + Attribute_Float -> ( 1 , GLSetVertexAttribArray ) + Attribute_V2F -> ( 2 , GLSetVertexAttribArray ) + Attribute_V3F -> ( 3 , GLSetVertexAttribArray ) + Attribute_V4F -> ( 4 , GLSetVertexAttribArray ) + Attribute_M22F -> ( 4 , GLSetVertexAttribArray ) + Attribute_M23F -> ( 6 , GLSetVertexAttribArray ) + Attribute_M24F -> ( 8 , GLSetVertexAttribArray ) + Attribute_M32F -> ( 6 , GLSetVertexAttribArray ) + Attribute_M33F -> ( 9 , GLSetVertexAttribArray ) + Attribute_M34F -> ( 12 , GLSetVertexAttribArray ) + Attribute_M42F -> ( 8 , GLSetVertexAttribArray ) + Attribute_M43F -> ( 12 , GLSetVertexAttribArray ) + Attribute_M44F -> ( 16 , GLSetVertexAttribArray ) + +drawElementsCommand :: GLenum -> IndexStream Buffer -> GLObjectCommand +drawElementsCommand prim (IndexStream (Buffer arrs bo) arrIdx start idxCount) + = GLDrawElements prim (fromIntegral idxCount) idxType bo ptr + where + ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx + idxType = arrayTypeToGLType arrType + ptr = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType) + +objectDrawStyle :: (GLsizei -> [(GLint,GLsizei)]) -- ^ mask, normally \x -> [(0,x)] + -> Object + -> Either [(GLint,GLsizei)] (IndexStream Buffer) +objectDrawStyle streamMask obj = case objIndices obj of + Nothing -> Left $ let cnt = head [c | Stream _ _ _ _ c <- Map.elems (objAttributes obj)] + in streamMask $ fromIntegral cnt + Just idxStream -> Right idxStream + +-- backward-compatible non-masking interface. +createObjectCommands :: Map.Map String (IORef GLint) -> Map.Map String GLUniform -> Object -> GLProgram -> [GLObjectCommand] +createObjectCommands texUnitMap topUnis obj prg = + createObjectCommands_ (objectEnvironment texUnitMap topUnis obj (pure . ((,) 0))) prg + +data ObjectEnvironment = ObjectEnvironment + { envPrim :: GLenum + , envDrawStyle :: Either [(GLint,GLsizei)] (IndexStream Buffer) + , tlookup :: String -> IORef GLint + , ulookup :: String -> GLUniform + , alookup :: String -> Stream Buffer + } + +objectEnvironment :: Map.Map String (IORef GLint) + -> Map.Map String GLUniform + -> Object + -> (GLsizei -> [(GLint, GLsizei)]) + -> ObjectEnvironment +objectEnvironment texUnitMap topUnis obj streamMask = ObjectEnvironment + { envPrim = primitiveToGLType $ objPrimitive obj + , envDrawStyle = objectDrawStyle streamMask obj + , tlookup = \n -> Map.findWithDefault (error $ "missing texture unit: " ++ show n) n texUnitMap + , ulookup = lookupOrLookup "missing uniform: " (objUniSetup obj) topUnis + , alookup = \n -> Map.findWithDefault (error $ "missing attribute: " ++ n) n $ objAttributes obj + } + + +createObjectCommands_ :: ObjectEnvironment -> GLProgram -> [GLObjectCommand] +createObjectCommands_ ObjectEnvironment{..} prg = concat + [ map (setUniformCommand ulookup) $ Map.toList (inputUniforms prg) + , map (bindTextureCommand tlookup ulookup) $ toList (inputTextureUniforms prg) + , map (setVertexAttribCommmand alookup) $ Map.elems (inputStreams prg) + , case envDrawStyle of + Left ranges -> map (uncurry $ GLDrawArrays envPrim) ranges + Right indexed -> pure $ drawElementsCommand envPrim indexed + ] + +updateCommands :: GLStorage + -> Object + -> (GLsizei -> [(GLint,GLsizei)]) + -> IO Object +updateCommands input obj mask = do + let cmdsRef = objCommands obj :: IORef (V.Vector (V.Vector [GLObjectCommand])) + slotIdx = objSlot obj :: Int + ppls <- readIORef $ pipelines input + cmds <- V.forM (ppls :: V.Vector (Maybe GLRenderer)) $ \mp -> case mp of + Nothing -> return V.empty + Just p -> do + let env = objectEnvironment (glTexUnitMapping p) (uniformSetup input) obj mask + Just ic <- readIORef $ glInput p + case icSlotMapInputToPipeline ic ! slotIdx of + Nothing -> return V.empty -- this slot is not used in that pipeline + Just pSlotIdx -> do + let emptyV = V.replicate (V.length $ glPrograms p) [] + return $ emptyV // [(prgIdx,createObjectCommands_ env (glPrograms p ! prgIdx)) + | prgIdx <- glSlotPrograms p ! pSlotIdx] + writeIORef cmdsRef cmds + return obj + + +-- TODO: Add flexibility. +-- Currently this allocates a buffer consisting of a single named vertex attribute that +-- must be of type V3F. +uploadDynamicBuffer :: Int -> String -> IO GPUData +uploadDynamicBuffer sz attrname = do + bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo + glBindBuffer GL_ARRAY_BUFFER bo + let bufsize = 3 * fromIntegral sz + byteCount = 4 * bufsize + glBufferData GL_ARRAY_BUFFER byteCount nullPtr GL_DYNAMIC_DRAW + glBindBuffer GL_ARRAY_BUFFER 0 + let buffer = Buffer (V.singleton $ ArrayDesc ArrFloat (fromIntegral bufsize) 0 (fromIntegral byteCount)) + bo + gd = GPUData PointList (Map.singleton attrname $ Stream Attribute_V3F buffer 0 0 sz) Nothing [buffer] + return gd + + +incrementalUpdateBuffer :: MonadIO m => Buffer -> GLintptr -> GLsizeiptr -> Ptr a -> m () +incrementalUpdateBuffer b byteoffset bytecount ptr = do + glBindBuffer GL_ARRAY_BUFFER (bufGLObj b) + glBufferSubData GL_ARRAY_BUFFER byteoffset bytecount ptr + glBindBuffer GL_ARRAY_BUFFER 0 diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs index ff55df5..10040d5 100644 --- a/PointPrimitiveRing.hs +++ b/PointPrimitiveRing.hs @@ -24,10 +24,12 @@ import LambdaCube.GL.Util import LambdaCube.GL.Input.Type import LambdaCube.GL.Input hiding (createObjectCommands) -import Graphics.GL.Core33 +-- import Graphics.GL.Core33 + +import MaskableStream data Ring = Ring - { rBufferObject :: Word32 + { rBufferObject :: Buffer , rStorage :: GLStorage , rObject :: Object , rSize :: IORef CPtrdiff -- Current count of Floats in the ring buffer. @@ -35,172 +37,22 @@ data Ring = Ring , ringCapacity :: CPtrdiff -- Maximum number of floats in buffer. } -addToObjectArray :: GLStorage - -> String -- ^ Slot name for a PrimitiveStream. - -> [String] -- ^ Uniform names. IORefs will be put in 'objUniSetup'. - -> GPUData - -> IO Object -addToObjectArray input slotName objUniNames (GPUData prim streams indices _) = do - let ObjectArraySchema _ slotStreams = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName) - $ Map.lookup slotName $! objectArrays $! schema input - addObject input slotName prim indices (Map.intersection streams slotStreams) objUniNames - -setUniformCommand :: (String -> GLUniform) - -> (String,GLint) - -> GLObjectCommand -setUniformCommand ulookup (n,i) = GLSetUniform i (ulookup n) - -bindTextureCommand :: (String -> IORef GLint) - -> (String -> GLUniform) - -> String - -> GLObjectCommand -bindTextureCommand tlookup ulookup n = GLBindTexture (inputTypeToTextureTarget $ uniInputType u) (tlookup n) u - where - u = ulookup n - uniInputType (GLTypedUniform ty _) = unwitnessType ty - uniInputType (GLUniform r) = objectType r - - -lookupOrLookup :: (Ord k, Show k) => String -> Map.Map k a -> Map.Map k a -> k -> a -lookupOrLookup callsite objUnis topUnis n = Map.findWithDefault (topUni n) n objUnis - where - topUni n = Map.findWithDefault (error $ "internal error ("++callsite++"): " ++ show n) n topUnis - - -classifyStreamType :: StreamType -> ( GLint - , GLuint -> GLuint -> GLint -> GLenum -> Ptr () -> GLObjectCommand) -classifyStreamType = \case - Attribute_Word -> ( 1 , GLSetVertexAttribIArray ) - Attribute_V2U -> ( 2 , GLSetVertexAttribIArray ) - Attribute_V3U -> ( 3 , GLSetVertexAttribIArray ) - Attribute_V4U -> ( 4 , GLSetVertexAttribIArray ) - Attribute_Int -> ( 1 , GLSetVertexAttribIArray ) - Attribute_V2I -> ( 2 , GLSetVertexAttribIArray ) - Attribute_V3I -> ( 3 , GLSetVertexAttribIArray ) - Attribute_V4I -> ( 4 , GLSetVertexAttribIArray ) - Attribute_Float -> ( 1 , GLSetVertexAttribArray ) - Attribute_V2F -> ( 2 , GLSetVertexAttribArray ) - Attribute_V3F -> ( 3 , GLSetVertexAttribArray ) - Attribute_V4F -> ( 4 , GLSetVertexAttribArray ) - Attribute_M22F -> ( 4 , GLSetVertexAttribArray ) - Attribute_M23F -> ( 6 , GLSetVertexAttribArray ) - Attribute_M24F -> ( 8 , GLSetVertexAttribArray ) - Attribute_M32F -> ( 6 , GLSetVertexAttribArray ) - Attribute_M33F -> ( 9 , GLSetVertexAttribArray ) - Attribute_M34F -> ( 12 , GLSetVertexAttribArray ) - Attribute_M42F -> ( 8 , GLSetVertexAttribArray ) - Attribute_M43F -> ( 12 , GLSetVertexAttribArray ) - Attribute_M44F -> ( 16 , GLSetVertexAttribArray ) - -drawElementsCommand :: GLenum -> IndexStream Buffer -> GLObjectCommand -drawElementsCommand prim (IndexStream (Buffer arrs bo) arrIdx start idxCount) - = GLDrawElements prim (fromIntegral idxCount) idxType bo ptr - where - ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx - idxType = arrayTypeToGLType arrType - ptr = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType) - -objectDrawStyle :: (GLsizei -> [(GLint,GLsizei)]) -- ^ mask, normally \x -> [(0,x)] - -> Object - -> Either [(GLint,GLsizei)] (IndexStream Buffer) -objectDrawStyle streamMask obj = case objIndices obj of - Nothing -> Left $ let cnt = head [c | Stream _ _ _ _ c <- Map.elems (objAttributes obj)] - in streamMask $ fromIntegral cnt - Just idxStream -> Right idxStream - - -createObjectCommands :: Map.Map String (IORef GLint) -> Map.Map String GLUniform -> Object -> GLProgram -> [GLObjectCommand] -createObjectCommands texUnitMap topUnis obj prg = - createObjectCommands_ (objectEnvironment texUnitMap topUnis obj (pure . ((,) 0))) prg - -createObjectCommands_ :: ObjectEnvironment -> GLProgram -> [GLObjectCommand] -createObjectCommands_ ObjectEnvironment{..} prg = concat - [ map (setUniformCommand ulookup) $ Map.toList (inputUniforms prg) - , map (bindTextureCommand tlookup ulookup) $ toList (inputTextureUniforms prg) - , map (setVertexAttribCommmand alookup) $ Map.elems (inputStreams prg) - , case envDrawStyle of - Left ranges -> map (uncurry $ GLDrawArrays envPrim) ranges - Right indexed -> pure $ drawElementsCommand envPrim indexed - ] - -data ObjectEnvironment = ObjectEnvironment - { envPrim :: GLenum - , envDrawStyle :: Either [(GLint,GLsizei)] (IndexStream Buffer) - , tlookup :: String -> IORef GLint - , ulookup :: String -> GLUniform - , alookup :: String -> Stream Buffer - } - -objectEnvironment :: Map.Map String (IORef GLint) - -> Map.Map String GLUniform - -> Object - -> (GLsizei -> [(GLint, GLsizei)]) - -> ObjectEnvironment -objectEnvironment texUnitMap topUnis obj streamMask = ObjectEnvironment - { envPrim = primitiveToGLType $ objPrimitive obj - , envDrawStyle = objectDrawStyle streamMask obj - , tlookup = \n -> Map.findWithDefault (error $ "missing texture unit: " ++ show n) n texUnitMap - , ulookup = lookupOrLookup "missing uniform: " (objUniSetup obj) topUnis - , alookup = \n -> Map.findWithDefault (error $ "missing attribute: " ++ n) n $ objAttributes obj - } - - -setVertexAttribCommmand :: (t -> Stream Buffer) -> (GLuint, t) -> GLObjectCommand -setVertexAttribCommmand alookup (i,name) = case alookup name of - Stream ty (Buffer arrs bo) arrIdx start len -> mkAttrCmd i bo n (arrayTypeToGLType arrType) (intPtrToPtr $! offset) - where - (n, mkAttrCmd) = classifyStreamType ty - ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx - offset = fromIntegral (arrOffs + start * fromIntegral n * sizeOfArrayType arrType) - - -- constant generic attribute - constAttr -> GLSetVertexAttrib i constAttr - -updateCommands :: GLStorage - -> Object - -> (GLsizei -> [(GLint,GLsizei)]) - -> IO Object -updateCommands input obj mask = do - let cmdsRef = objCommands obj :: IORef (V.Vector (V.Vector [GLObjectCommand])) - slotIdx = objSlot obj :: Int - ppls <- readIORef $ pipelines input - cmds <- V.forM (ppls :: V.Vector (Maybe GLRenderer)) $ \mp -> case mp of - Nothing -> return V.empty - Just p -> do - let env = objectEnvironment (glTexUnitMapping p) (uniformSetup input) obj mask - Just ic <- readIORef $ glInput p - case icSlotMapInputToPipeline ic ! slotIdx of - Nothing -> return V.empty -- this slot is not used in that pipeline - Just pSlotIdx -> do - let emptyV = V.replicate (V.length $ glPrograms p) [] - return $ emptyV // [(prgIdx,createObjectCommands_ env (glPrograms p ! prgIdx)) - | prgIdx <- glSlotPrograms p ! pSlotIdx] - writeIORef cmdsRef cmds - return obj - newRing :: GLStorage -> Int -> IO Ring newRing storage sz = do - bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo - glBindBuffer GL_ARRAY_BUFFER bo - let bufsize = 3 * fromIntegral sz - byteCount = 4 * bufsize - glBufferData GL_ARRAY_BUFFER byteCount nullPtr GL_DYNAMIC_DRAW - glBindBuffer GL_ARRAY_BUFFER 0 startRef <- newIORef 0 sizeRef <- newIORef 0 - let buffer = Buffer (V.singleton $ ArrayDesc ArrFloat (fromIntegral bufsize) 0 (fromIntegral byteCount)) - bo - gd = GPUData PointList (Map.singleton "position" $ Stream Attribute_V3F buffer 0 0 sz) Nothing [buffer] + gd <- uploadDynamicBuffer sz "position" obj <- addToObjectArray storage "Points" [] gd readIORef (objCommands obj) >>= mapM_ print -- [[GLSetUniform 0 GLUniform M44F,GLSetVertexAttribArray 0 5 3 5126 0x0000000000000000,GLDrawArrays 0 0 1],[],[],[]] - let r = Ring + let bo = streamBuffer $ dStreams gd Map.! "position" + r = Ring { rBufferObject = bo , rStorage = storage , rObject = obj , rSize = sizeRef , rStart = startRef - , ringCapacity = bufsize + , ringCapacity = 3 * fromIntegral sz } updateRingCommands r return r @@ -224,11 +76,9 @@ pushBack r x y z = allocaArray 3 $ \ptr -> do pokeElemOff ptr 2 z start <- readIORef $ rStart r writeIORef (rStart r) (mod (start + 3) (ringCapacity r)) - glBindBuffer GL_ARRAY_BUFFER (rBufferObject r) - glBufferSubData GL_ARRAY_BUFFER (4*start) (4*3) ptr - glBindBuffer GL_ARRAY_BUFFER 0 - glFlush - glFinish + incrementalUpdateBuffer (rBufferObject r) (4*start) (4*3) ptr + -- glFlush + -- glFinish sz <- readIORef (rSize r) putStrLn $ "pushBack "++show (sz,start,(x,y,z)) when (sz < ringCapacity r) $ do -- cgit v1.2.3