Allocate fillRect in C, not in GC

Author: chrisdone

bench/Space.hs

@@ -48,9 +48,9 @@ main =
             (\weight ->
                if weightGCs weight > 0
                  then Just "Non-zero number of garbage collections!"
-                 else if weightAllocatedBytes weight > 3000
+                 else if weightAllocatedBytes weight > 4000
                         then Just
-                               "Allocated >3KB! Allocations should be constant."
+                               "Allocated >4KB! Allocations should be constant."
                         else Nothing)
           | i <- [1, 10, 100, 1000]
           ]
@@ -62,12 +62,27 @@ main =
             (\weight ->
                if weightGCs weight > 0
                  then Just "Non-zero number of garbage collections!"
-                 else if weightAllocatedBytes weight > 3000
+                 else if weightAllocatedBytes weight > 4000
                         then Just
-                               "Allocated >3KB! Allocations should be constant."
+                               "Allocated >KB! Allocations should be constant."
                         else Nothing)
           | i <- [1, 10, 100, 1000, 2000]
-          ])
+          ]
+        sequence_
+          [ validateAction
+            ("pollEvent + drawRect " ++ show i)
+            pollEventDrawRectTest
+            i
+            (\weight ->
+               if weightGCs weight > 0
+                 then Just "Non-zero number of garbage collections!"
+                 else if weightAllocatedBytes weight > 4000
+                        then Just
+                               "Allocated >4KB! Allocations should be constant."
+                        else Nothing)
+          | i <- [1, 10, 100, 1000]
+          ]
+    )
 
 -- | Test that merely polling does not allocate or engage the GC.
 -- <https://github.com/haskell-game/sdl2/issues/178>
@@ -101,7 +116,7 @@ pollEventClearTest iters = do
 pollEventPresentTest :: Int -> IO ()
 pollEventPresentTest iters = do
   initializeAll
-  window <- createWindow "pollEventClearTest" defaultWindow
+  window <- createWindow "pollEventPresentTest" defaultWindow
   renderer <- createRenderer window (-1) defaultRenderer
   let go :: Int -> IO ()
       go 0 = pure ()
@@ -117,7 +132,7 @@ pollEventPresentTest iters = do
 pollEventDrawColorTest :: Int -> IO ()
 pollEventDrawColorTest iters = do
   initializeAll
-  window <- createWindow "pollEventClearTest" defaultWindow
+  window <- createWindow "pollEventDrawColorTest" defaultWindow
   renderer <- createRenderer window (-1) defaultRenderer
   let go :: Int -> IO ()
       go 0 = pure ()
@@ -128,3 +143,21 @@ pollEventDrawColorTest iters = do
         present renderer
         go (i - 1)
   go iters
+
+-- | Draw a rectangle on screen.
+pollEventDrawRectTest :: Int -> IO ()
+pollEventDrawRectTest iters = do
+  initializeAll
+  window <- createWindow "pollEventDrawRectTest" defaultWindow
+  renderer <- createRenderer window (-1) defaultRenderer
+  let go :: Int -> IO ()
+      go 0 = pure ()
+      go i = do
+        _ <- pollEvent
+        rendererDrawColor renderer $= V4 40 40 40 255
+        clear renderer
+        rendererDrawColor renderer $= V4 255 255 255 255
+        fillRect renderer (Just (Rectangle (P (V2 40 40)) (V2 80 80)))
+        present renderer
+        go (i - 1)
+  go iters

cbits/sdlhelper.c

@@ -75,3 +75,13 @@ int SDLHelper_SetError (const char *str)
 {
   return SDL_SetError ("%s", str);
 }
+
+int SDLHelper_RenderFillRectEx(SDL_Renderer*   renderer, int x, int y, int w, int h)
+{
+  SDL_Rect rect;
+  rect.x=x;
+  rect.y=y;
+  rect.w=w;
+  rect.h=h;
+  return SDL_RenderFillRect(renderer,&rect);
+}

src/SDL/Raw/Video.hs

@@ -110,6 +110,7 @@ module SDL.Raw.Video (
   renderDrawRect,
   renderDrawRects,
   renderFillRect,
+  renderFillRectEx,
   renderFillRects,
   renderGetClipRect,
   renderGetLogicalSize,
@@ -315,6 +316,7 @@ foreign import ccall "SDL.h SDL_RenderDrawPoints" renderDrawPointsFFI :: Rendere
 foreign import ccall "SDL.h SDL_RenderDrawRect" renderDrawRectFFI :: Renderer -> Ptr Rect -> IO CInt
 foreign import ccall "SDL.h SDL_RenderDrawRects" renderDrawRectsFFI :: Renderer -> Ptr Rect -> CInt -> IO CInt
 foreign import ccall "SDL.h SDL_RenderFillRect" renderFillRectFFI :: Renderer -> Ptr Rect -> IO CInt
+foreign import ccall "sqlhelper.c SDLHelper_RenderFillRectEx" renderFillRectExFFI :: Renderer -> CInt -> CInt -> CInt -> CInt -> IO CInt
 foreign import ccall "SDL.h SDL_RenderFillRects" renderFillRectsFFI :: Renderer -> Ptr Rect -> CInt -> IO CInt
 foreign import ccall "SDL.h SDL_RenderGetClipRect" renderGetClipRectFFI :: Renderer -> Ptr Rect -> IO ()
 foreign import ccall "SDL.h SDL_RenderGetLogicalSize" renderGetLogicalSizeFFI :: Renderer -> Ptr CInt -> Ptr CInt -> IO ()
@@ -822,6 +824,10 @@ renderDrawRects :: MonadIO m => Renderer -> Ptr Rect -> CInt -> m CInt
 renderDrawRects v1 v2 v3 = liftIO $ renderDrawRectsFFI v1 v2 v3
 {-# INLINE renderDrawRects #-}
 
+renderFillRectEx :: MonadIO m => Renderer -> CInt -> CInt -> CInt -> CInt -> m CInt
+renderFillRectEx v1 x y w h = liftIO $ renderFillRectExFFI v1 x y w h
+{-# INLINE renderFillRectEx #-}
+
 renderFillRect :: MonadIO m => Renderer -> Ptr Rect -> m CInt
 renderFillRect v1 v2 = liftIO $ renderFillRectFFI v1 v2
 {-# INLINE renderFillRect #-}

src/SDL/Video/Renderer.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveFunctor #-}
@@ -118,6 +119,7 @@ module SDL.Video.Renderer
   ) where
 
 import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Exception (catch, throw, SomeException, uninterruptibleMask_)
 import Data.Bits
 import Data.Data (Data)
 import Data.Foldable
@@ -623,15 +625,18 @@ drawRects (Renderer r) rects = liftIO $
 -- | Fill a rectangle on the current rendering target with the drawing color.
 --
 -- See @<https://wiki.libsdl.org/SDL_RenderFillRect SDL_RenderFillRect>@ for C documentation.
-fillRect :: MonadIO m
-         => Renderer
-         -> Maybe (Rectangle CInt) -- ^ The rectangle to fill. 'Nothing' for the entire rendering context.
-         -> m ()
-fillRect (Renderer r) rect = liftIO $ do
+fillRect ::
+     MonadIO m
+  => Renderer
+  -> Maybe (Rectangle CInt) -- ^ The rectangle to fill.
+  -> m ()
+fillRect (Renderer r) rect =
+  liftIO $
   throwIfNeg_ "SDL.Video.fillRect" "SDL_RenderFillRect" $
-    maybeWith with rect $ \rPtr ->
-      Raw.renderFillRect r
-                         (castPtr rPtr)
+  case rect of
+    Nothing -> Raw.renderFillRect r nullPtr
+    Just (Rectangle (P (V2 x y)) (V2 w h)) -> Raw.renderFillRectEx r x y w h
+{-# INLINE fillRect #-}
 
 -- | Fill some number of rectangles on the current rendering target with the drawing color.
 --