mitigating memory leak, changing to IORef and making widnow movable

This commit is contained in:
nek0 2017-02-19 22:28:10 +01:00
parent 97186c5709
commit 79f3bd4b9f
2 changed files with 39 additions and 18 deletions

View file

@ -18,12 +18,12 @@ import qualified GEGL as G
import qualified Data.Text as T import qualified Data.Text as T
import Data.Maybe import Data.Maybe
import Data.IORef
import System.Clock import System.Clock
import Control.Monad.Loops import Control.Monad.Loops
import Control.Monad.State import Control.Monad.State
import Control.Concurrent.MVar
import Foreign.C.Types (CInt(..)) import Foreign.C.Types (CInt(..))
import Foreign.Storable (peek) import Foreign.Storable (peek)
@ -47,11 +47,19 @@ withAffection AffectionConfig{..} = do
Only is -> Only is ->
SDL.initialize is SDL.initialize is
G.gegl_init G.gegl_init
execTime <- newMVar =<< getTime Monotonic execTime <- newIORef =<< getTime Monotonic
window <- SDL.createWindow windowTitle windowConfig window <- SDL.createWindow windowTitle windowConfig
-- let surface = (flip SDL.Surface Nothing) rawSurfacePtr -- let surface = (flip SDL.Surface Nothing) rawSurfacePtr
(oldSurf, surface) <- getSurfaces window (oldSurf, surface) <- getSurfaces window
let (SDL.Surface ptr _) = surface
rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0
pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek rawSurfacePtr
SDL.V2 (CInt rw) (CInt rh) <- liftIO $ SDL.surfaceDimensions surface
let (w, h) = (fromIntegral rw, fromIntegral rh)
stride = (fromIntegral $ Raw.pixelFormatBytesPerPixel pixelFormat) * w
pixels <- SDL.surfacePixels $ surface
let bablFormat = B.PixelFormat B.RGBA B.CFu8 let bablFormat = B.PixelFormat B.RGBA B.CFu8
cpp = B.babl_components_per_pixel bablFormat
format <- B.babl_format bablFormat format <- B.babl_format bablFormat
initContainer <- (\x -> AffectionData initContainer <- (\x -> AffectionData
{ quitEvent = False { quitEvent = False
@ -60,12 +68,17 @@ withAffection AffectionConfig{..} = do
, windowSurface = oldSurf , windowSurface = oldSurf
, drawSurface = surface , drawSurface = surface
, drawFormat = format , drawFormat = format
, drawPixels = pixels
, drawDimensions = (w, h)
, drawStride = stride
, drawCPP = cpp
, drawStack = [] , drawStack = []
, elapsedTime = 0 , elapsedTime = 0
}) <$> loadState surface }) <$> loadState surface
(_, nState) <- runStateT ( A.runState $ do (_, nState) <- runStateT ( A.runState $ do
preLoop preLoop
liftIO $ SDL.surfaceBlit surface Nothing oldSurf Nothing pad <- get
liftIO $ SDL.surfaceBlit (drawSurface pad) Nothing (windowSurface pad) Nothing
whileM_ (do whileM_ (do
current <- get current <- get
return $ not $ A.quitEvent current return $ not $ A.quitEvent current
@ -73,19 +86,11 @@ withAffection AffectionConfig{..} = do
(do (do
-- Measure time difference form last run -- Measure time difference form last run
now <- liftIO $ getTime Monotonic now <- liftIO $ getTime Monotonic
lastTime <- liftIO $ fromMaybe now <$> tryReadMVar execTime lastTime <- liftIO $ readIORef execTime
-- get state -- get state
ad <- get ad <- get
-- clean draw requests from last run -- clean draw requests from last run
pixels <- SDL.surfacePixels $ drawSurface ad mapM_ (invalidateDrawRequest (drawPixels ad) (drawStride ad) (drawCPP ad)) (drawStack ad)
(SDL.Surface ptr _) <- SDL.getWindowSurface window
rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0
pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek rawSurfacePtr
SDL.V2 (CInt rw) (CInt rh) <- liftIO $ SDL.surfaceDimensions surface
let (w, h) = (fromIntegral rw, fromIntegral rh)
stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w
cpp = B.babl_components_per_pixel bablFormat
mapM_ (invalidateDrawRequest pixels stride cpp) $ drawStack ad
-- compute dt and update elapsedTime -- compute dt and update elapsedTime
let dt = (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / (fromIntegral 10 ^ 9) let dt = (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / (fromIntegral 10 ^ 9)
put $ ad put $ ad
@ -100,7 +105,8 @@ withAffection AffectionConfig{..} = do
drawLoop drawLoop
-- handle all new draw requests -- handle all new draw requests
ad2 <- get ad2 <- get
clear <- catMaybes <$> mapM (handleDrawRequest pixels stride cpp) (drawStack ad2) clear <- catMaybes <$>
mapM (handleDrawRequest (drawPixels ad) (drawStride ad) (drawCPP ad)) (drawStack ad2)
-- save all draw requests to clear in next run -- save all draw requests to clear in next run
put $ ad2 put $ ad2
{ drawStack = clear } { drawStack = clear }
@ -112,8 +118,7 @@ withAffection AffectionConfig{..} = do
Nothing Nothing
liftIO $ SDL.updateWindowSurface $ drawWindow ad2 liftIO $ SDL.updateWindowSurface $ drawWindow ad2
-- save new time -- save new time
_ <- liftIO $ swapMVar execTime $ now liftIO $ writeIORef execTime $ now
return ()
) )
) initContainer ) initContainer
G.gegl_exit G.gegl_exit
@ -142,9 +147,19 @@ preHandleEvents evs =
putNewSurface = do putNewSurface = do
ad <- get ad <- get
(oldSurf, surface) <- liftIO $ getSurfaces $ drawWindow ad (oldSurf, surface) <- liftIO $ getSurfaces $ drawWindow ad
pixels <- SDL.surfacePixels $ surface
SDL.V2 (CInt rw) (CInt rh) <- liftIO $ SDL.surfaceDimensions surface
let (SDL.Surface ptr _) = surface
rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0
pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek rawSurfacePtr
let (w, h) = (fromIntegral rw, fromIntegral rh)
stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w
put ad put ad
{ windowSurface = oldSurf { windowSurface = oldSurf
, drawSurface = surface , drawSurface = surface
, drawPixels = pixels
, drawDimensions = (w, h)
, drawStride = stride
} }
-- | Return the userstate to the user -- | Return the userstate to the user

View file

@ -44,6 +44,8 @@ import Control.Monad.State
-- import Control.Concurrent.MVar -- import Control.Concurrent.MVar
import Foreign.Ptr (Ptr)
-- | Configuration for the aplication. needed at startup. -- | Configuration for the aplication. needed at startup.
data AffectionConfig us = AffectionConfig data AffectionConfig us = AffectionConfig
{ initComponents :: InitComponents { initComponents :: InitComponents
@ -79,6 +81,10 @@ data AffectionData us = AffectionData
, drawSurface :: SDL.Surface -- ^ SDL surface , drawSurface :: SDL.Surface -- ^ SDL surface
, drawFormat :: B.BablFormatPtr -- ^ Target format , drawFormat :: B.BablFormatPtr -- ^ Target format
, drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed , drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed
, drawPixels :: Ptr () -- ^ Destination Pixel buffer
, drawDimensions :: (Int, Int) -- ^ Dimensions of target surface
, drawStride :: Int -- ^ Stride of target buffer
, drawCPP :: Int -- ^ Number of components per pixel
, clearStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be invalidated , clearStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be invalidated
, elapsedTime :: Double -- ^ Elapsed time in seconds , elapsedTime :: Double -- ^ Elapsed time in seconds
} }