haskell-gi-base 0.21.1 → 0.21.2

raw patch · 7 files changed

+173/−47 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−1
• Data/GI/Base/Attributes.hs +1/−0
• Data/GI/Base/BasicTypes.hs +2/−0
• Data/GI/Base/ManagedPtr.hs +71/−18
• Data/GI/Base/Utils.hsc +11/−1
• c/hsgclosure.c +82/−26
• haskell-gi-base.cabal +1/−1

@@ -1,6 +1,10 @@+### 0.21.2+++ Export [newManagedPtr_](https://hackage.haskell.org/package/haskell-gi-base-0.21.2/docs/Data-GI-Base-ManagedPtr.html#v:newManagedPtr_).+ ### 0.21.1 -+ Remove the `::=` and `::~` constructors in `AttrOp`, since they cannot really be used for anything, since they are pure functions.++ Remove the `::=` and `::~` constructors in `AttrOp`, since they cannot really be used for anything, as they are pure functions.  ### 0.21.0 

@@ -242,6 +242,7 @@  -- | Possible operations on an attribute. data AttrOpTag = AttrGet | AttrSet | AttrConstruct | AttrClear+  deriving (Eq, Ord, Enum, Bounded, Show)  #if MIN_VERSION_base(4,9,0) -- | A user friendly description of the `AttrOpTag`, useful when

@@ -63,6 +63,8 @@ -- the foreign ptr. data ManagedPtr a = ManagedPtr {       managedForeignPtr :: ForeignPtr a+    , managedPtrAllocCallStack :: Maybe CallStack+    -- ^ `CallStack` for the call that created the pointer.     , managedPtrIsDisowned :: IORef (Maybe CallStack)     -- ^ When disowned, the `CallStack` for the disowning call.     }

@@ -14,6 +14,7 @@     -- * Managed pointers       newManagedPtr     , newManagedPtr'+    , newManagedPtr_     , withManagedPtr     , maybeWithManagedPtr     , withManagedPtrList@@ -50,7 +51,10 @@  import Data.Coerce (coerce) import Data.IORef (newIORef, readIORef, writeIORef, IORef)-import Data.Maybe (isNothing)+import Data.Maybe (isNothing, isJust)+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ((<>))+#endif  import Foreign.C (CInt(..)) import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr)@@ -63,28 +67,50 @@                                prettyCallStack, callStack) import Data.GI.Base.Utils +import qualified Data.Text as T+ import System.IO (hPutStrLn, stderr)+import System.Environment (lookupEnv)  -- | Thin wrapper over `Foreign.Concurrent.newForeignPtr`.-newManagedPtr :: Ptr a -> IO () -> IO (ManagedPtr a)+newManagedPtr :: HasCallStack => Ptr a -> IO () -> IO (ManagedPtr a) newManagedPtr ptr finalizer = do-  let ownedFinalizer :: IORef (Maybe CallStack) -> IO ()-      ownedFinalizer callStackRef = do-        cs <- readIORef callStackRef-        when (isNothing cs) finalizer   isDisownedRef <- newIORef Nothing-  fPtr <- FC.newForeignPtr ptr (ownedFinalizer isDisownedRef)+  dbgMode <- isJust <$> lookupEnv "HASKELL_GI_DEBUG_MEM"+  let dbgCallStack = if dbgMode+                     then Just callStack+                     else Nothing+  fPtr <- FC.newForeignPtr ptr (ownedFinalizer finalizer ptr dbgCallStack isDisownedRef)   return $ ManagedPtr {                managedForeignPtr = fPtr+             , managedPtrAllocCallStack = dbgCallStack              , managedPtrIsDisowned = isDisownedRef              } +-- | Run the finalizer for an owned pointer, assuming it has now been+-- disowned.+ownedFinalizer :: IO () -> Ptr a -> Maybe CallStack -> IORef (Maybe CallStack)+               -> IO ()+ownedFinalizer finalizer ptr allocCallStack callStackRef = do+  cs <- readIORef callStackRef+  -- cs will be @Just cs@ whenever the pointer has been disowned.+  when (isNothing cs) $ do+    maybe (return ()) (printAllocDebug ptr) allocCallStack+    finalizer++-- | Print some debug diagnostics for an allocation.+printAllocDebug :: Ptr a -> CallStack -> IO ()+printAllocDebug ptr allocCS =+  (dbgLog . T.pack) ("Releasing <" <> show ptr <> ">. "+                     <> "Callstack for allocation was:\n"+                     <> prettyCallStack allocCS <> "\n\n")+ foreign import ccall "dynamic"    mkFinalizer :: FinalizerPtr a -> Ptr a -> IO ()  -- | Version of `newManagedPtr` taking a `FinalizerPtr` and a -- corresponding `Ptr`, as in `Foreign.ForeignPtr.newForeignPtr`.-newManagedPtr' :: FinalizerPtr a -> Ptr a -> IO (ManagedPtr a)+newManagedPtr' :: HasCallStack => FinalizerPtr a -> Ptr a -> IO (ManagedPtr a) newManagedPtr' finalizer ptr = newManagedPtr ptr (mkFinalizer finalizer ptr)  -- | Thin wrapper over `Foreign.Concurrent.newForeignPtr_`.@@ -94,6 +120,7 @@   fPtr <- newForeignPtr_ ptr   return $ ManagedPtr {                managedForeignPtr = fPtr+             , managedPtrAllocCallStack = Nothing              , managedPtrIsDisowned = isDisownedRef              } @@ -257,8 +284,10 @@ -- | Decrease the reference count of the given 'GObject'. The memory -- associated with the object may be released if the reference count -- reaches 0.-unrefObject :: GObject a => a -> IO ()-unrefObject obj = withManagedPtr obj dbg_g_object_unref+unrefObject :: (HasCallStack, GObject a) => a -> IO ()+unrefObject obj = withManagedPtr obj $ \ptr -> do+  dbgDealloc obj+  dbg_g_object_unref ptr  -- | Print some debug info (if the right environment valiable is set) -- about the object being disowned.@@ -268,10 +297,11 @@ -- | Disown a GObject, that is, do not unref the associated foreign -- GObject when the Haskell object gets garbage collected. Returns the -- pointer to the underlying GObject.-disownObject :: GObject a => a -> IO (Ptr b)+disownObject :: (HasCallStack, GObject a) => a -> IO (Ptr b) disownObject obj = withManagedPtr obj $ \ptr -> do-                     dbg_g_object_disown ptr-                     castPtr <$> disownManagedPtr obj+  dbgDealloc obj+  dbg_g_object_disown ptr+  castPtr <$> disownManagedPtr obj  -- It is fine to use unsafe here, since all this does is schedule an -- idle callback. The scheduling itself will never block for a long@@ -284,7 +314,7 @@  -- | Construct a Haskell wrapper for the given boxed object. We make a -- copy of the object.-newBoxed :: forall a. BoxedObject a => (ManagedPtr a -> a) -> Ptr a -> IO a+newBoxed :: forall a. (HasCallStack, BoxedObject a) => (ManagedPtr a -> a) -> Ptr a -> IO a newBoxed constructor ptr = do   GType gtype <- boxedType (undefined :: a)   ptr' <- g_boxed_copy gtype ptr@@ -293,14 +323,14 @@  -- | Like 'newBoxed', but we do not make a copy (we "steal" the passed -- object, so now it is managed by the Haskell runtime).-wrapBoxed :: forall a. BoxedObject a => (ManagedPtr a -> a) -> Ptr a -> IO a+wrapBoxed :: forall a. (HasCallStack, BoxedObject a) => (ManagedPtr a -> a) -> Ptr a -> IO a wrapBoxed constructor ptr = do   GType gtype <- boxedType (undefined :: a)   fPtr <- newManagedPtr ptr (boxed_free_helper gtype ptr)   return $! constructor fPtr  -- | Make a copy of the given boxed object.-copyBoxed :: forall a. BoxedObject a => a -> IO (Ptr a)+copyBoxed :: forall a. (HasCallStack, BoxedObject a) => a -> IO (Ptr a) copyBoxed b = do   GType gtype <- boxedType b   withManagedPtr b (g_boxed_copy gtype)@@ -321,6 +351,7 @@ freeBoxed boxed = do   GType gtype <- boxedType (undefined :: a)   ptr <- disownManagedPtr boxed+  dbgDealloc boxed   g_boxed_free gtype ptr  -- | Disown a boxed object, that is, do not free the associated@@ -330,7 +361,7 @@ disownBoxed = disownManagedPtr  -- | Wrap a pointer, taking ownership of it.-wrapPtr :: WrappedPtr a => (ManagedPtr a -> a) -> Ptr a -> IO a+wrapPtr :: (HasCallStack, WrappedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a wrapPtr constructor ptr = do   fPtr <- case wrappedPtrFree of             Nothing -> newManagedPtr_ ptr@@ -338,7 +369,7 @@   return $! constructor fPtr  -- | Wrap a pointer, making a copy of the data.-newPtr :: WrappedPtr a => (ManagedPtr a -> a) -> Ptr a -> IO a+newPtr :: (HasCallStack, WrappedPtr a) => (ManagedPtr a -> a) -> Ptr a -> IO a newPtr constructor ptr = do   tmpWrap <- newManagedPtr_ ptr   ptr' <- wrappedPtrCopy (constructor tmpWrap)@@ -351,3 +382,25 @@   ptr' <- wrappedPtrCalloc   memcpy ptr' ptr size   return ptr'++foreign import ccall unsafe "g_thread_self" g_thread_self :: IO (Ptr ())++-- | Print a debug message for deallocs if the @HASKELL_GI_DEBUG_MEM@+-- environment variable has been set.+dbgDealloc :: (HasCallStack, ManagedPtrNewtype a) => a -> IO ()+dbgDealloc m = do+  env <- lookupEnv "HASKELL_GI_DEBUG_MEM"+  case env of+    Nothing -> return ()+    Just _ -> do+      let mPtr = coerce m :: ManagedPtr ()+          ptr = (unsafeForeignPtrToPtr . managedForeignPtr) mPtr+      threadPtr <- g_thread_self+      hPutStrLn stderr ("Releasing <" ++ show ptr ++ "> from thread ["+                         ++ show threadPtr ++ "].\n"+                         ++ (case managedPtrAllocCallStack mPtr of+                               Just allocCS -> "• Callstack for allocation:\n"+                                               ++ prettyCallStack allocCS ++ "\n\n"+                               Nothing -> "")+                         ++ "• CallStack for deallocation:\n"+                         ++ prettyCallStack callStack ++ "\n")

@@ -24,6 +24,7 @@     , maybeReleaseFunPtr     , checkUnexpectedReturnNULL     , checkUnexpectedNothing+    , dbgLog     ) where  #include <glib-object.h>@@ -35,11 +36,12 @@ import Control.Monad (void)  import qualified Data.Text as T+import qualified Data.Text.Foreign as TF import Data.Monoid ((<>)) import Data.Word  import Foreign (peek)-import Foreign.C.Types (CSize(..))+import Foreign.C.Types (CSize(..), CChar) import Foreign.Ptr (Ptr, nullPtr, FunPtr, nullFunPtr, freeHaskellFunPtr) import Foreign.Storable (Storable(..)) @@ -204,3 +206,11 @@                                      "This is a bug in the introspection data, please report it at\nhttps://github.com/haskell-gi/haskell-gi/issues\n" <>                                      T.pack (prettyCallStack callStack)                  })++foreign import ccall unsafe "dbg_log_with_len" dbg_log_with_len ::+        Ptr CChar -> Int -> IO ()++-- | Print a string to the debug log in an atomic way (so the output+-- of different threads does not get intermingled).+dbgLog :: T.Text -> IO ()+dbgLog msg = TF.withCStringLen msg $ \(ptr, len) -> dbg_log_with_len ptr len

@@ -3,12 +3,74 @@ /* GHC's semi-public Rts API */ #include <Rts.h> +#include <stdarg.h> #include <stdlib.h> #include <string.h>+#include <pthread.h>  #include <glib-object.h> #include <glib.h> +static int print_debug_info ()+{+  static int __print_debug_info = -1;++  if (__print_debug_info == -1) {+    __print_debug_info = getenv ("HASKELL_GI_DEBUG_MEM") != NULL;+  }++  return __print_debug_info;+}++/*+  A mutex protecting the log file handle. We make it recursive,+  i.e. refcounted, so it is OK to lock repeatedly in the same thread.+*/+static pthread_mutex_t log_mutex = PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP;++/* Give the current thread exclusive access to the log */+static void lock_log()+{+  pthread_mutex_lock(&log_mutex);+}++/* Decrease the refcount of the mutex protecting access to the log+   from other threads */+static void unlock_log()+{+  pthread_mutex_unlock(&log_mutex);+}++/* Print the given message to the log. The passed in string does not+   need to be zero-terminated. The message is only printed if the+   HASKELL_GI_DEBUG_MEM variable is set. */+void dbg_log_with_len (const char *msg, int len)+{+  if (print_debug_info()) {+    lock_log();+    fwrite(msg, len, 1, stderr);+    unlock_log();+  }+}++/* Print the given printf-style message to the log. The message is+   only printed if the HASKELL_GI_DEBUG_MEM variable is set. */+__attribute__ ((format (gnu_printf, 1, 2)))+static void dbg_log (const char *msg, ...)+{+  va_list args;++  va_start(args, msg);++  if (print_debug_info()) {+    lock_log();+    vfprintf(stderr, msg, args);+    unlock_log();+  }++  va_end(args);+}+ int check_object_type(void *instance, GType type) {   int result;@@ -17,23 +79,12 @@      result = !!G_TYPE_CHECK_INSTANCE_TYPE(instance, type);   } else {     result = 0;-    fprintf(stderr, "Check failed: got a null pointer\n");+    dbg_log("Check failed: got a null pointer\n");   }    return result; } -static int print_debug_info ()-{-  static int __print_debug_info = -1;--  if (__print_debug_info == -1) {-    __print_debug_info = getenv ("HASKELL_GI_DEBUG_MEM") != NULL;-  }--  return __print_debug_info;-}- /* Information about a boxed type to free */ typedef struct {   GType gtype;@@ -48,16 +99,17 @@    if (print_debug_info()) {     GThread *self = g_thread_self ();--    fprintf(stderr, "Freeing a boxed object at %p from idle callback [thread: %p]\n",+    lock_log();+    dbg_log("Freeing a boxed object at %p from idle callback [thread: %p]\n",             info->boxed, self);-    fprintf(stderr, "\tIt is of type %s\n", g_type_name(info->gtype));+    dbg_log("\tIt is of type %s\n", g_type_name(info->gtype));   }    g_boxed_free (info->gtype, info->boxed);    if (print_debug_info()) {-    fprintf(stderr, "\tdone\n");+    dbg_log("\tdone freeing %p.\n", info->boxed);+    unlock_log();   }    g_free(info);@@ -80,12 +132,13 @@   GType gtype;    if (print_debug_info()) {+    lock_log();     GThread *self = g_thread_self();-    fprintf(stderr, "Disowning a GObject at %p [thread: %p]\n", obj, self);+    dbg_log("Disowning a GObject at %p [thread: %p]\n", obj, self);     gtype = G_TYPE_FROM_INSTANCE (obj);-    fprintf(stderr, "\tIt is of type %s\n", g_type_name(gtype));-    fprintf(stderr, "\tIts refcount before disowning is %d\n",-            (int)obj->ref_count);+    dbg_log("\tIt is of type %s\n", g_type_name(gtype));+    dbg_log("\tIts refcount before disowning is %d\n", (int)obj->ref_count);+    unlock_log();   } } @@ -94,11 +147,10 @@   GThread *self = g_thread_self();   GType gtype; -  fprintf(stderr, "Unref of %p from idle callback [thread: %p]\n", obj, self);+  dbg_log("Unref of %p from idle callback [thread: %p]\n", obj, self);   gtype = G_TYPE_FROM_INSTANCE (obj);-  fprintf(stderr, "\tIt is of type %s\n", g_type_name(gtype));-  fprintf(stderr, "\tIts refcount before unref is %d\n",-          (int)obj->ref_count);+  dbg_log("\tIt is of type %s\n", g_type_name(gtype));+  dbg_log("\tIts refcount before unref is %d\n", (int)obj->ref_count); }  /*@@ -111,6 +163,7 @@ g_object_unref_in_main_loop (gpointer obj) {   if (print_debug_info()) {+    lock_log();     print_object_dbg_info ((GObject*)obj);   } @@ -118,6 +171,7 @@    if (print_debug_info()) {     fprintf(stderr, "\tUnref done\n");+    unlock_log();   }    return FALSE; /* Do not invoke again */@@ -151,7 +205,8 @@   if (print_debug_info()) {     GThread *self = g_thread_self(); -    fprintf(stderr, "Creating a new GObject of type %s [thread: %p]\n",+    lock_log();+    dbg_log("Creating a new GObject of type %s [thread: %p]\n",             g_type_name(gtype), self);   } @@ -187,7 +242,8 @@   }    if (print_debug_info()) {-    fprintf(stderr, "\tdone, got a pointer at %p\n", result);+    dbg_log("\tdone, got a pointer at %p\n", result);+    unlock_log();   }    return result;

@@ -1,5 +1,5 @@ name:                haskell-gi-base-version:             0.21.1+version:             0.21.2 synopsis:            Foundation for libraries generated by haskell-gi description:         Foundation for libraries generated by haskell-gi homepage:            https://github.com/haskell-gi/haskell-gi-base