Show EGL errors by using EGL_KHR_debug

glest.cabal

@@ -58,6 +58,7 @@ library
   import: shared-properties
   exposed-modules:
     Glest.Egl
+    Glest.Egl.Debug
     Glest.Egl.Types
     Glest.Renderer
     Glest.Utils.InlineC

src/Glest/Egl.hs

 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}
 
 module Glest.Egl (
   Egl,
@@ -17,11 +16,10 @@ import Control.Exception
 import Data.Foldable (elem)
 import Data.Bits ((.&.), (.|.), shiftL, shiftR)
 import Data.Set (Set)
-import qualified Data.Set as Set
+import Data.Set qualified as Set
 import Foreign
-import Foreign.C.Error
-import Foreign.C.String
-import Foreign.C.Types
+import Foreign.C
+import Glest.Egl.Debug
 import Glest.Egl.Types
 import Glest.Utils.InlineC
 import Graphics.GL.Types
@@ -33,8 +31,6 @@ import System.Posix.ByteString.FilePath (RawFilePath, withFilePath)
 
 C.context ctx
 
-C.include "<assert.h>"
-C.include "<fcntl.h>"
 C.include "<stdint.h>"
 C.include "<unistd.h>"
 C.include "<EGL/egl.h>"
@@ -57,22 +53,7 @@ data EglException = EglException EGLint
   deriving (Eq, Exception)
 
 instance Show EglException where
-  show (EglException 0x3000) = "EGL_SUCCESS"
-  show (EglException 0x3001) = "EGL_NOT_INITIALIZED"
-  show (EglException 0x3002) = "EGL_BAD_ACCESS"
-  show (EglException 0x3003) = "EGL_BAD_ALLOC"
-  show (EglException 0x3004) = "EGL_BAD_ATTRIBUTE"
-  show (EglException 0x3005) = "EGL_BAD_CONTEXT"
-  show (EglException 0x3006) = "EGL_BAD_CONFIG"
-  show (EglException 0x3007) = "EGL_BAD_CURRENT_SURFACE"
-  show (EglException 0x3008) = "EGL_BAD_DISPLAY"
-  show (EglException 0x3009) = "EGL_BAD_SURFACE"
-  show (EglException 0x300a) = "EGL_BAD_MATCH"
-  show (EglException 0x300b) = "EGL_BAD_PARAMETER"
-  show (EglException 0x300c) = "EGL_BAD_NATIVE_PIXMAP"
-  show (EglException 0x300d) = "EGL_BAD_NATIVE_WINDOW"
-  show (EglException 0x300e) = "EGL_CONTEXT_LOST"
-  show _ = "Invalid EGL error number"
+  show (EglException value) = toErrorMessage value
 
 eglGetError :: IO EglException
 eglGetError = EglException <$> [CU.exp| EGLint { eglGetError() } |]
@@ -86,7 +67,18 @@ initializeEgl = do
 
   traceIO $ mconcat ["EGL client extensions: ", clientExtensionsString]
 
-  let clientExtensions = Set.fromList (words clientExtensionsString)
+  let
+    clientExtensions = Set.fromList (words clientExtensionsString)
+    requiredClientExtensions :: Set String = Set.fromList [
+      "EGL_KHR_debug"
+      ]
+    missingClientExtensions = Set.difference requiredClientExtensions clientExtensions
+
+  unless (Set.null missingClientExtensions) $
+    fail $ "Missing EGL client extensions: " <> intercalate " " missingClientExtensions
+
+  -- EGL_KHR_debug is available, so the debug callback should be attached immediately
+  initializeEglDebugHandler
 
   unless ("EGL_EXT_device_enumeration" `elem` clientExtensions && "EGL_EXT_device_query" `elem` clientExtensions) do
     fail "Missing extensions for device enumeration"
@@ -242,7 +234,7 @@ eglCreateGLImage Egl{display, context} glTexture = do
   -- EGLImage requires EGL 1.5
   -- EGLImage is available in EGL 1.4 with EGL_KHR_image_base and EGL_KHR_gl_image
   throwErrnoIfNull "eglCreateImage"
-    [CU.exp| EGLImage { eglCreateImage($(EGLDisplay display), $(EGLContext context), EGL_GL_TEXTURE_2D, (EGLClientBuffer) $(GLuint glTexture), NULL) } |]
+    [CU.exp| EGLImage { eglCreateImage($(EGLDisplay display), $(EGLContext context), EGL_GL_TEXTURE_2D, (EGLClientBuffer)(intptr_t) $(GLuint glTexture), NULL) } |]
 
 data Dmabuf = Dmabuf {
   fourcc :: Word32,

src/Glest/Egl/Debug.hs

+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Glest.Egl.Debug (
+  initializeEglDebugHandler,
+  toErrorMessage
+) where
+
+import Data.List (intersperse, singleton)
+import Glest.Egl.Types
+import Glest.Utils.InlineC
+import Foreign
+import Foreign.C
+import Language.C.Inline qualified as C
+import Language.C.Inline.Unsafe qualified as CU
+import Quasar.Prelude
+
+C.context ctx
+
+C.include "<stdint.h>"
+C.include "<unistd.h>"
+C.include "<EGL/egl.h>"
+C.include "<EGL/eglext.h>"
+
+C.verbatim "PFNEGLDEBUGMESSAGECONTROLKHRPROC eglDebugMessageControlKHR;"
+
+
+data EglDebugMsgType
+  = EglDebugMsgCritical -- ^ EGL_DEBUG_MSG_CRITICAL_KHR
+  | EglDebugMsgError -- ^ EGL_DEBUG_MSG_ERROR_KHR
+  | EglDebugMsgWarning -- ^ EGL_DEBUG_MSG_WARN_KHR
+  | EglDebugMsgInfo -- ^ EGL_DEBUG_MSG_INFO_KHR
+  deriving stock Show
+
+toDebugMessageType :: EGLint -> IO EglDebugMsgType
+toDebugMessageType 0x33B9 = pure EglDebugMsgCritical
+toDebugMessageType 0x33BA = pure EglDebugMsgError
+toDebugMessageType 0x33BB = pure EglDebugMsgWarning
+toDebugMessageType 0x33BC = pure EglDebugMsgInfo
+toDebugMessageType _ = fail "Invalid EGL debug message type value"
+
+-- | Converts an EGLint or EGLenum error value to a string representation
+toErrorMessage :: (Eq a, Num a, Show a) => a -> String
+toErrorMessage 0x3000 = "EGL_SUCCESS"
+toErrorMessage 0x3001 = "EGL_NOT_INITIALIZED"
+toErrorMessage 0x3002 = "EGL_BAD_ACCESS"
+toErrorMessage 0x3003 = "EGL_BAD_ALLOC"
+toErrorMessage 0x3004 = "EGL_BAD_ATTRIBUTE"
+toErrorMessage 0x3005 = "EGL_BAD_CONFIG"
+toErrorMessage 0x3006 = "EGL_BAD_CONTEXT"
+toErrorMessage 0x3007 = "EGL_BAD_CURRENT_SURFACE"
+toErrorMessage 0x3008 = "EGL_BAD_DISPLAY"
+toErrorMessage 0x3009 = "EGL_BAD_MATCH"
+toErrorMessage 0x300a = "EGL_BAD_NATIVE_PIXMAP"
+toErrorMessage 0x300b = "EGL_BAD_NATIVE_WINDOW"
+toErrorMessage 0x300c = "EGL_BAD_PARAMETER"
+toErrorMessage 0x300d = "EGL_BAD_SURFACE"
+toErrorMessage 0x300e = "EGL_CONTEXT_LOST"
+toErrorMessage value = mconcat ["Invalid EGL error enum value (", show value, ")"]
+
+initializeEglDebugHandler :: IO ()
+initializeEglDebugHandler = do
+  -- Requires EGL_KHR_debug
+  [CU.block|
+    void {
+      eglDebugMessageControlKHR = (PFNEGLDEBUGMESSAGECONTROLKHRPROC)eglGetProcAddress("eglDebugMessageControlKHR");
+    }
+  |]
+
+  -- NOTE callbackPtr is never freed - the code currently assumes the debug handler is set up once and will not change
+  callbackPtr <- makeDebugCallbackPtr
+  result <- [CU.block|
+    EGLint {
+      static const EGLAttrib attributes[] = {
+        // DEBUG_MSG_ERROR and CRITICAL are enabled by default
+        EGL_DEBUG_MSG_WARN_KHR, EGL_TRUE,
+        // terminate list
+        EGL_NONE
+      };
+      return eglDebugMessageControlKHR($(EGLDEBUGPROCKHR callbackPtr), attributes);
+    }
+  |]
+  when (result == [CU.pure|EGLint {EGL_BAD_ATTRIBUTE}|]) $ fail "eglDebugMessageControlKHR failed: EGL_BAD_ATTRIBUTE"
+  unless (result == [CU.pure|EGLint {EGL_SUCCESS}|]) $ fail "eglDebugMessageControlKHR failed (unknown error)"
+
+  traceIO $ "EGL debug initialized"
+
+makeDebugCallbackPtr :: IO (FunPtr EglDebugCallback)
+makeDebugCallbackPtr = $(C.mkFunPtr [t| EglDebugCallback |]) debugCallback
+
+debugCallback :: EglDebugCallback
+debugCallback err command messageType _threadLabel _objectLabel message = do
+
+  parsedMessageType <- toDebugMessageType messageType
+  (header, items) <- pure case parsedMessageType of
+    EglDebugMsgCritical -> ("EGL critical: ", [toErrorMessage err])
+    EglDebugMsgError -> ("EGL error: ", [toErrorMessage err])
+    EglDebugMsgWarning -> ("EGL warning: ", [])
+    EglDebugMsgInfo -> ("EGL info: ", [])
+
+  messageItem <- if message == nullPtr then pure [] else singleton . ("message = " <>) . show <$> peekCString message
+
+  commandItem <- singleton . ("command = " <>) <$> peekCString command
+
+  traceIO $ mconcat (header : intersperse ", " (items <> messageItem <> commandItem))

src/Glest/Egl/Types.hs

 module Glest.Egl.Types (
+  EGLenum,
   EGLint,
   EGLBoolean,
   EGLDisplay,
@@ -6,11 +7,15 @@ module Glest.Egl.Types (
   EGLContext,
   EGLDeviceEXT,
   EGLImage,
+  EGLLabel,
+  EglDebugCallback,
 ) where
 
 import Foreign
+import Foreign.C
 import Quasar.Prelude
 
+type EGLenum = Word32
 type EGLint = Int32
 type EGLBoolean = Word32
 type EGLDisplay = Ptr ()
@@ -18,3 +23,6 @@ type EGLConfig = Ptr ()
 type EGLContext = Ptr ()
 type EGLDeviceEXT = Ptr ()
 type EGLImage = Ptr ()
+type EGLLabel = Ptr ()
+
+type EglDebugCallback = EGLenum -> CString -> EGLint -> EGLLabel -> EGLLabel -> CString -> IO ()

src/Glest/Utils/InlineC.hs

@@ -7,6 +7,7 @@ module Glest.Utils.InlineC (
 import Data.Map.Strict as Map
 import Glest.Egl.Types
 import Graphics.GL.Types
+import Foreign
 import Language.C.Inline.Context
 import Language.C.Types
 import Language.Haskell.TH
@@ -37,11 +38,14 @@ types = [
 
   (TypeName "GLuint", [t|GLuint|]),
 
+  (TypeName "EGLenum", [t|EGLenum|]),
   (TypeName "EGLint", [t|EGLint|]),
   (TypeName "EGLBoolean", [t|EGLBoolean|]),
   (TypeName "EGLConfig", [t|EGLConfig|]),
   (TypeName "EGLContext", [t|EGLContext|]),
   (TypeName "EGLDisplay", [t|EGLDisplay|]),
   (TypeName "EGLDeviceEXT", [t|EGLDeviceEXT|]),
-  (TypeName "EGLImage", [t|EGLImage|])
+  (TypeName "EGLImage", [t|EGLImage|]),
+  (TypeName "EGLLabel", [t|EGLLabel|]),
+  (TypeName "EGLDEBUGPROCKHR", [t|FunPtr EglDebugCallback|])
   ]