diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for dyepack + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/dyepack.cabal b/dyepack.cabal new file mode 100644 --- /dev/null +++ b/dyepack.cabal @@ -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 diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -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 + diff --git a/src/Debug/Dyepack.hs b/src/Debug/Dyepack.hs new file mode 100644 --- /dev/null +++ b/src/Debug/Dyepack.hs @@ -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 ()