diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,6 @@ +# 2.1.8 [2024.05.04] +* Fix a memory leak in `reifyTypeable`. + # 2.1.7 [2023.02.28] * When building with `base-4.18` (GHC 9.6) or later, implement `reifyNat` and `reifySymbol` using the API provided by `GHC.TypeLits` instead of resorting diff --git a/examples/reflection-examples.cabal b/examples/reflection-examples.cabal --- a/examples/reflection-examples.cabal +++ b/examples/reflection-examples.cabal @@ -22,9 +22,9 @@ , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 - , GHC == 9.2.6 - , GHC == 9.4.4 - , GHC == 9.6.1 + , GHC == 9.2.8 + , GHC == 9.4.5 + , GHC == 9.6.2 flag examples default: True @@ -53,10 +53,10 @@ build-depends: -- TODO: Eventually, we should bump the lower version -- bounds to >=2 so that we can remove some CPP in FromJSON. - aeson >= 1 && < 2.2, + aeson >= 1 && < 2.3, base >= 4.9 && < 5, microlens, - microlens-aeson, + microlens-aeson >= 2.5.1, reflection, semigroups, tagged, diff --git a/fast/Data/Reflection.hs b/fast/Data/Reflection.hs --- a/fast/Data/Reflection.hs +++ b/fast/Data/Reflection.hs @@ -108,6 +108,7 @@ ) where import Control.Applicative +import Control.Exception #ifdef MIN_VERSION_template_haskell import Control.Monad @@ -522,8 +523,15 @@ } newtype W (b0 :: *) (b1 :: *) (b2 :: *) (b3 :: *) = W (W b0 b1 b2 b3) deriving Typeable +newtype StableBox (w0 :: *) (w1 :: *) (a :: *) = StableBox (StableBox w0 w1 a) deriving Typeable newtype Stable (w0 :: *) (w1 :: *) (a :: *) = Stable (Stable w0 w1 a) deriving Typeable +data Box a = Box a + +stableBox :: p (Stable w1 w2 a) -> Proxy (StableBox w1 w2 a) +stableBox _ = Proxy +{-# INLINE stableBox #-} + stable :: p b0 -> p b1 -> p b2 -> p b3 -> p b4 -> p b5 -> p b6 -> p b7 -> Proxy (Stable (W b0 b1 b2 b3) (W b4 b5 b6 b7) a) stable _ _ _ _ _ _ _ _ = Proxy @@ -537,35 +545,35 @@ intPtrToStablePtr = castPtrToStablePtr . intPtrToPtr {-# INLINE intPtrToStablePtr #-} -byte0 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b0 +byte0 :: p (StableBox (W b0 b1 b2 b3) w1 a) -> Proxy b0 byte0 _ = Proxy -byte1 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b1 +byte1 :: p (StableBox (W b0 b1 b2 b3) w1 a) -> Proxy b1 byte1 _ = Proxy -byte2 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b2 +byte2 :: p (StableBox (W b0 b1 b2 b3) w1 a) -> Proxy b2 byte2 _ = Proxy -byte3 :: p (Stable (W b0 b1 b2 b3) w1 a) -> Proxy b3 +byte3 :: p (StableBox (W b0 b1 b2 b3) w1 a) -> Proxy b3 byte3 _ = Proxy -byte4 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b4 +byte4 :: p (StableBox w0 (W b4 b5 b6 b7) a) -> Proxy b4 byte4 _ = Proxy -byte5 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b5 +byte5 :: p (StableBox w0 (W b4 b5 b6 b7) a) -> Proxy b5 byte5 _ = Proxy -byte6 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b6 +byte6 :: p (StableBox w0 (W b4 b5 b6 b7) a) -> Proxy b6 byte6 _ = Proxy -byte7 :: p (Stable w0 (W b4 b5 b6 b7) a) -> Proxy b7 +byte7 :: p (StableBox w0 (W b4 b5 b6 b7) a) -> Proxy b7 byte7 _ = Proxy argument :: (p s -> r) -> Proxy s argument _ = Proxy instance (B b0, B b1, B b2, B b3, B b4, B b5, B b6, B b7, w0 ~ W b0 b1 b2 b3, w1 ~ W b4 b5 b6 b7) - => Reifies (Stable w0 w1 a) a where + => Reifies (StableBox w0 w1 a) (Box a) where reflect = r where r = unsafePerformIO $ const <$> deRefStablePtr p <* freeStablePtr p s = argument r @@ -580,12 +588,24 @@ (reflectByte (byte7 s) `shiftL` 56) {-# NOINLINE reflect #-} --- This had to be moved to the top level, due to an apparent bug in --- the ghc inliner introduced in ghc 7.0.x -reflectBefore :: forall (proxy :: * -> *) s b. (Proxy s -> b) -> proxy s -> b -reflectBefore f = const $! f Proxy -{-# NOINLINE reflectBefore #-} +instance Reifies (StableBox w0 w1 a) (Box b) => Reifies (Stable w0 w1 a) b where + reflect p = case reflect (stableBox p) of + Box a -> a +-- Ensure that exactly one dictionary of Reifies (StableBox ...) is created and evaluated per reifyTypeable call. +-- +-- Evaluating the dictionary's thunk frees the allocated StablePtr, and the contents of the StablePtr replace the thunk. +-- Creating two dictionaries would mean a double free upon their evaluation, and leaving a dictionary unevaluated would +-- leak the StablePtr (see https://github.com/ekmett/reflection/issues/54). +-- +-- To separate evaluation of the dictionary and evaluation of the actual argument passed to reifyTypeable, we insert a +-- Box in between. +withStableBox :: Reifies (StableBox w0 w1 a) (Box a) => (Reifies (Stable w0 w1 a) a => Proxy (Stable w0 w1 a) -> r) -> Proxy (Stable w0 w1 a) -> IO r +withStableBox k p = do + _ <- evaluate $ reflect (stableBox p) + evaluate $ k p +{-# NOINLINE withStableBox #-} + -- | Reify a value at the type level in a 'Typeable'-compatible fashion, to be recovered with 'reflect'. -- -- This can be necessary to work around the changes to @Data.Typeable@ in GHC HEAD. @@ -595,7 +615,7 @@ #else reifyTypeable a k = unsafePerformIO $ do #endif - p <- newStablePtr a + p <- newStablePtr (Box a) let n = stablePtrToIntPtr p reifyByte (fromIntegral n) (\s0 -> reifyByte (fromIntegral (n `shiftR` 8)) (\s1 -> @@ -605,9 +625,7 @@ reifyByte (fromIntegral (n `shiftR` 40)) (\s5 -> reifyByte (fromIntegral (n `shiftR` 48)) (\s6 -> reifyByte (fromIntegral (n `shiftR` 56)) (\s7 -> - reflectBefore (fmap return k) $ - stable s0 s1 s2 s3 s4 s5 s6 s7)))))))) - + withStableBox k $ stable s0 s1 s2 s3 s4 s5 s6 s7)))))))) data ReifiedMonoid a = ReifiedMonoid { reifiedMappend :: a -> a -> a, reifiedMempty :: a } diff --git a/reflection.cabal b/reflection.cabal --- a/reflection.cabal +++ b/reflection.cabal @@ -1,5 +1,5 @@ name: reflection -version: 2.1.7 +version: 2.1.8 license: BSD3 license-file: LICENSE author: Edward A. Kmett, Elliott Hird, Oleg Kiselyov and Chung-chieh Shan @@ -44,9 +44,9 @@ , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 - , GHC == 9.2.6 - , GHC == 9.4.4 - , GHC == 9.6.1 + , GHC == 9.2.8 + , GHC == 9.4.5 + , GHC == 9.6.2 extra-source-files: .hlint.yaml @@ -129,7 +129,7 @@ build-tool-depends: hspec-discover:hspec-discover >= 1.8 build-depends: base >= 2 && < 5, - containers >= 0.1 && < 0.7, + containers >= 0.1 && < 0.8, hspec >= 2 && < 3, QuickCheck >= 2 && < 3, reflection diff --git a/slow/Data/Reflection.hs b/slow/Data/Reflection.hs --- a/slow/Data/Reflection.hs +++ b/slow/Data/Reflection.hs @@ -1,8 +1,11 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-cse #-} {-# OPTIONS_GHC -fno-full-laziness #-} {-# OPTIONS_GHC -fno-float-in #-} @@ -49,6 +52,7 @@ import Foreign.StablePtr import System.IO.Unsafe import Control.Applicative +import Control.Exception import Data.Proxy import Data.Bits import Data.Word @@ -115,9 +119,18 @@ -- reified type. reflect :: proxy s -> a +newtype StableBox b0 b1 b2 b3 b4 b5 b6 b7 a = + StableBox (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) newtype Stable b0 b1 b2 b3 b4 b5 b6 b7 a = Stable (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) +data Box a = Box a + +stableBox :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) + -> Proxy (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) +stableBox _ = Proxy +{-# INLINE stableBox #-} + stable :: p b0 -> p b1 -> p b2 -> p b3 -> p b4 -> p b5 -> p b6 -> p b7 -> Proxy (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) stable _ _ _ _ _ _ _ _ = Proxy @@ -131,35 +144,35 @@ intPtrToStablePtr = castPtrToStablePtr . intPtrToPtr {-# INLINE intPtrToStablePtr #-} -byte0 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b0 +byte0 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b0 byte0 _ = Proxy -byte1 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b1 +byte1 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b1 byte1 _ = Proxy -byte2 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b2 +byte2 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b2 byte2 _ = Proxy -byte3 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b3 +byte3 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b3 byte3 _ = Proxy -byte4 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b4 +byte4 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b4 byte4 _ = Proxy -byte5 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b5 +byte5 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b5 byte5 _ = Proxy -byte6 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b6 +byte6 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b6 byte6 _ = Proxy -byte7 :: p (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b7 +byte7 :: p (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) -> Proxy b7 byte7 _ = Proxy argument :: (p s -> r) -> Proxy s argument _ = Proxy instance (B b0, B b1, B b2, B b3, B b4, B b5, B b6, B b7) - => Reifies (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) a where + => Reifies (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) (Box a) where reflect = r where r = unsafePerformIO $ const <$> deRefStablePtr p <* freeStablePtr p s = argument r @@ -174,12 +187,34 @@ (reflectByte (byte7 s) `shiftL` 56) {-# NOINLINE reflect #-} --- This had to be moved to the top level, due to an apparent bug in --- the ghc inliner introduced in ghc 7.0.x -reflectBefore :: Reifies s a => (Proxy s -> b) -> proxy s -> b -reflectBefore f = const $! f Proxy -{-# NOINLINE reflectBefore #-} +instance Reifies (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) (Box b) + => Reifies (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) b where + reflect p = case reflect (stableBox p) of + Box a -> a +-- Ensure that exactly one dictionary of Reifies (StableBox ...) is created and +-- evaluated per reifyTypeable call. +-- +-- Evaluating the dictionary's thunk frees the allocated StablePtr, and the +-- contents of the StablePtr replace the thunk. Creating two dictionaries would +-- mean a double free upon their evaluation, and leaving a dictionary +-- unevaluated would leak the StablePtr +-- (see https://github.com/ekmett/reflection/issues/54). +-- +-- To separate evaluation of the dictionary and evaluation of the actual +-- argument passed to reifyTypeable, we insert a Box in between. +withStableBox + :: Reifies (StableBox b0 b1 b2 b3 b4 b5 b6 b7 a) (Box a) + => (Reifies (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) a + => Proxy (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) + -> r) + -> Proxy (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) + -> IO r +withStableBox k p = do + _ <- evaluate $ reflect (stableBox p) + evaluate $ k p +{-# NOINLINE withStableBox #-} + -- | Reify a value at the type level, to be recovered with 'reflect'. reify :: a -> (forall s. (Reifies s a) => Proxy s -> r) -> r reify a k = unsafeDupablePerformIO $ do @@ -193,5 +228,4 @@ reifyByte (fromIntegral (n `shiftR` 40)) (\s5 -> reifyByte (fromIntegral (n `shiftR` 48)) (\s6 -> reifyByte (fromIntegral (n `shiftR` 56)) (\s7 -> - reflectBefore (fmap return k) $ - stable s0 s1 s2 s3 s4 s5 s6 s7)))))))) + withStableBox k $ stable s0 s1 s2 s3 s4 s5 s6 s7))))))))