From b5d68cc4aba82fec53e156a6c0c2d2726ee6ff46 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Fri, 17 May 2019 03:55:38 -0400 Subject: Point primitive stream based ring buffer. --- PointPrimitiveRing.hs | 239 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 239 insertions(+) create mode 100644 PointPrimitiveRing.hs (limited to 'PointPrimitiveRing.hs') diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs new file mode 100644 index 0000000..bd9a15b --- /dev/null +++ b/PointPrimitiveRing.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE LambdaCase, RecordWildCards #-} +module PointPrimitiveRing where + +import Control.Monad +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 + +data Ring = Ring + { rBufferObject :: Word32 + , rStorage :: GLStorage + , rObject :: Object + , rSize :: IORef CPtrdiff + , rStart :: IORef CPtrdiff + , ringCapacity :: CPtrdiff + } + +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] + 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 + { rBufferObject = bo + , rStorage = storage + , rObject = obj + , rSize = sizeRef + , rStart = startRef + , ringCapacity = bufsize + } + updateRingCommands r + return r + +updateRingCommands :: Ring -> IO () +updateRingCommands r = do + start <- fmap (fromIntegral . (`div` 3)) $ readIORef $ rStart r + size <- fmap (fromIntegral . (`div` 3)) $ readIORef $ rSize r + let mask 0 = [] + mask cnt = if start + size < cnt + then [(start,size)] + else [(0,start + size - cnt), (start,cnt-start)] + updateCommands (rStorage r) (rObject r) mask + readIORef (objCommands $ rObject r) >>= mapM_ print + return () + +pushBack :: Ring -> Float -> Float -> Float -> IO () +pushBack r x y z = allocaArray 3 $ \ptr -> do + pokeElemOff ptr 0 x + pokeElemOff ptr 1 y + 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 + sz <- readIORef (rSize r) + putStrLn $ "pushBack "++show (sz,start,(x,y,z)) + when (sz < ringCapacity r) $ do + writeIORef (rSize r) (sz + 3) + updateRingCommands r + +updateRingUniforms :: GLStorage -> Ring -> IO () +updateRingUniforms _ _ = return () -- cgit v1.2.3