dyepack (empty) → 0.1.0.0

raw patch · 6 files changed

+162/−0 lines, 6 filesdep +basedep +dyepackdep +generics-sopsetup-changed

Dependencies added: base, dyepack, generics-sop

Files

• CHANGELOG.md +5/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• dyepack.cabal +42/−0
• example/Main.hs +24/−0
• src/Debug/Dyepack.hs +59/−0

@@ -0,0 +1,5 @@+# Revision history for dyepack++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -0,0 +1,30 @@+Copyright (c) 2019, Matthew Pickering++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Matthew Pickering nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,42 @@+cabal-version:       2.4+-- Initial package description 'dyepack.cabal' generated by 'cabal init'.+-- For further documentation, see http://haskell.org/cabal/users-guide/++name:                dyepack+version:             0.1.0.0+synopsis:            Programatically identify space leaks in your program.+description:         Identifier space leaks in your program using Simon Marlow's+                     weak pointer technique.+-- bug-reports:+license:             BSD-3-Clause+license-file:        LICENSE+author:              Matthew Pickering+maintainer:          matthewtpickering@gmail.com+-- copyright:+-- category:+extra-source-files:  CHANGELOG.md++library+  exposed-modules:     Debug.Dyepack+  -- other-modules:+  -- other-extensions:+  build-depends:       base ^>=4.12.0.0+                     , generics-sop+  hs-source-dirs:      src+  default-language:    Haskell2010++Flag examples+  description: Build example+  manual: True+  default: False++executable example+  if !flag(examples)+    buildable: False+  main-is:             Main.hs+  build-depends:       base ^>=4.12.0.0+                     , dyepack+  default-language:    Haskell2010+  hs-source-dirs:      example+  if flag(examples)+    ghc-options: -fwhole-archive-hs-libs -debug -threaded -O0 -g3

@@ -0,0 +1,24 @@+{-# LANGUAGE DeriveGeneric #-}++module Main where++import Debug.Dyepack+import GHC.Generics+import Control.Concurrent++data A = A String deriving Show+data User = User A Int deriving Generic++main = do+  v <- getLine+  let a = A v+      y = id [a, a, a]+      u = User a 5++  dyed <- dye u+  -- This function will break the debugger if `a` is retained at this+  -- point+  checkDyed dyed (\s x -> print ("LEAKED: PAUSING:" ++ s) >> threadDelay 10000000)+  -- y retains a reference to a, so it can't be gced+  print y+

@@ -0,0 +1,59 @@+{-# LANGUAGE RankNTypes, ExistentialQuantification #-}+{-# LANGUAGE TypeApplications, FlexibleContexts #-}+{-# LANGUAGE BangPatterns, MagicHash, ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+module Debug.Dyepack (dye, checkDyed, Dyed(..)) where++import qualified GHC.Generics as GHC+import Generics.SOP+import Generics.SOP.GGP+import GHC.Exts+import System.Mem.Weak+import System.Mem++-- TODO: come up with a better name for Part+data Part = forall a. Part String (Weak a)++-- | Represents an object who's contents on the heap have been "dyed".+-- The dyed contents have weak pointers, which can then be used to check if they+-- are being retained.+newtype Dyed a = Dyed [Part]++-- | Create a new 'Dyed' that can be then used with 'checkDyed'. 'dye' will+-- make a 'Weak' pointer to each field in your type which can be used to+-- check if any part of the data type is leaking at a later part of the+-- program.+dye :: forall a . (GHC.Generic a+                  , GFrom a+                  , All (All Top) (GCode a)+                  , GDatatypeInfo a ) => a -> IO (Dyed a)+dye !x = do+  let parts :: [IO Part]+      parts = hcollapse $ hczipWith (Proxy @Top) go cinfo (unSOP $ gfrom x)++      cinfo = constructorInfo info+      info = gdatatypeInfo (Proxy @a)+  Dyed <$> sequence parts+  where go :: ConstructorInfo xs -> NP I xs -> K [IO Part] xs+        go (Constructor n) x = K (hcollapse $ hcmap (Proxy @Top) (doOne n) x)+        go (Infix n _ prec) x = K (hcollapse $ hcmap (Proxy @Top) (doOne n) x)+        go (Record n fi) x = K (goProd fi x)++        doOne d !(I !y) = K (Part d <$> mkWeakPtr y Nothing)++        goProd :: All Top xs => NP FieldInfo xs -> NP I xs -> [IO Part]+        goProd fi x = hcollapse $ hczipWith (Proxy @Top) (\(FieldInfo l) y -> doOne l y) fi x+++-- | Check if any part of 'Dyed' is being retained. The callback is triggered when+-- the object is retained.+checkDyed :: Dyed a -> (forall x . String -> x -> IO ()) -> IO ()+checkDyed (Dyed parts) k = do+  performGC+  mapM_ checkPart parts+  where+    checkPart (Part s wp) = do+      res <- deRefWeak wp+      case res of+        Just x -> k s x+        Nothing -> pure ()