diff --git a/Data/Reflection.hs b/Data/Reflection.hs --- a/Data/Reflection.hs +++ b/Data/Reflection.hs @@ -1,22 +1,41 @@ -{-# LANGUAGE Rank2Types, TypeFamilies #-} +-- CPP is provided by default-extensions, because it may not work in some compilers to #ifdef a pragma otherwise +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE MagicHash #-} +#endif {-# OPTIONS_GHC -fno-cse -fno-full-laziness -fno-float-in -fno-warn-unused-binds #-} ---------------------------------------------------------------------------- -- | -- Module : Data.Reflection --- Copyright : 2009-2012 Edward Kmett, 2004 Oleg Kiselyov and Chung-chieh Shan +-- Copyright : 2009-2012 Edward Kmett, +-- 2012 Elliott Hird, +-- 2004 Oleg Kiselyov and Chung-chieh Shan -- License : BSD3 -- -- Maintainer : Edward Kmett -- Stability : experimental --- Portability : non-portable (rank-2 types, type families) +-- Portability : non-portable (rank-2 types, type families, scoped type variables) -- -- Based on the Functional Pearl: Implicit Configurations paper by -- Oleg Kiselyov and Chung-chieh Shan. -- -- -- --- Modified to minimize extensions and work with Data.Proxy rather than --- explicit scoped type variables and undefined values by Edward Kmett. +-- The approach from the paper was modified to work with Data.Proxy and streamline +-- the API by Edward Kmett and Elliott Hird. +-- +-- Usage reduces to using two combinators, 'reify' and 'reflect'. +-- +-- > ghci> reify 6 (\p -> reflect p + reflect p) :: Int +-- > 12 +-- +-- The argument passed along by reify is just a @data Proxy t = +-- Proxy@, so all of the information needed to reconstruct your value +-- has been moved to the type level. This enables it to be used when +-- constructing instances (see @examples/Monoid.hs@). ------------------------------------------------------------------------------- module Data.Reflection @@ -24,94 +43,132 @@ -- * Reifying any term at the type level Reified(..) , reify - -- * Reifying integral values at the type level - , ReifiedNum(..) - , reifyIntegral ) where import Foreign.Ptr import Foreign.StablePtr import System.IO.Unsafe import Control.Applicative -import Prelude hiding (succ, pred) import Data.Proxy - -newtype Zero = Zero Zero deriving (Show) -newtype Twice s = Twice (Twice s) deriving (Show) -newtype SuccTwice s = SuccTwice (SuccTwice s) deriving (Show) -newtype PredTwice s = PredTwice (PredTwice s) deriving (Show) - -class ReifiedNum s where - reflectNum :: Num a => p s -> a - -instance ReifiedNum Zero where - reflectNum = pure 0 - -instance ReifiedNum s => ReifiedNum (Twice s) where - reflectNum p = 2 * reflectNum (pop p) +import Data.Bits +#ifdef __GLASGOW_HASKELL__ +import GHC.Word +#endif -instance ReifiedNum s => ReifiedNum (SuccTwice s) where - reflectNum p = 2 * reflectNum (pop p) + 1 +class B s where + reflectByte :: p s -> IntPtr -instance ReifiedNum s => ReifiedNum (PredTwice s) where - reflectNum p = 2 * reflectNum (pop p) - 1 +#define CAT(a,b) a/**/b -reifyIntegral :: Integral a => a -> (forall s. ReifiedNum s => Proxy s -> w) -> w -reifyIntegral i k = case quotRem i 2 of - (0, 0) -> zero k - (j, 0) -> reifyIntegral j (k . twice) - (j, 1) -> reifyIntegral j (k . succTwice) - (j,-1) -> reifyIntegral j (k . predTwice) - _ -> undefined +#define BYTES(GO) \ + GO(0) GO(1) GO(2) GO(3) GO(4) GO(5) GO(6) GO(7) GO(8) GO(9) GO(10) GO(11) \ + GO(12) GO(13) GO(14) GO(15) GO(16) GO(17) GO(18) GO(19) GO(20) GO(21) GO(22) \ + GO(23) GO(24) GO(25) GO(26) GO(27) GO(28) GO(29) GO(30) GO(31) GO(32) GO(33) \ + GO(34) GO(35) GO(36) GO(37) GO(38) GO(39) GO(40) GO(41) GO(42) GO(43) GO(44) \ + GO(45) GO(46) GO(47) GO(48) GO(49) GO(50) GO(51) GO(52) GO(53) GO(54) GO(55) \ + GO(56) GO(57) GO(58) GO(59) GO(60) GO(61) GO(62) GO(63) GO(64) GO(65) GO(66) \ + GO(67) GO(68) GO(69) GO(70) GO(71) GO(72) GO(73) GO(74) GO(75) GO(76) GO(77) \ + GO(78) GO(79) GO(80) GO(81) GO(82) GO(83) GO(84) GO(85) GO(86) GO(87) GO(88) \ + GO(89) GO(90) GO(91) GO(92) GO(93) GO(94) GO(95) GO(96) GO(97) GO(98) GO(99) \ + GO(100) GO(101) GO(102) GO(103) GO(104) GO(105) GO(106) GO(107) GO(108) \ + GO(109) GO(110) GO(111) GO(112) GO(113) GO(114) GO(115) GO(116) GO(117) \ + GO(118) GO(119) GO(120) GO(121) GO(122) GO(123) GO(124) GO(125) GO(126) \ + GO(127) GO(128) GO(129) GO(130) GO(131) GO(132) GO(133) GO(134) GO(135) \ + GO(136) GO(137) GO(138) GO(139) GO(140) GO(141) GO(142) GO(143) GO(144) \ + GO(145) GO(146) GO(147) GO(148) GO(149) GO(150) GO(151) GO(152) GO(153) \ + GO(154) GO(155) GO(156) GO(157) GO(158) GO(159) GO(160) GO(161) GO(162) \ + GO(163) GO(164) GO(165) GO(166) GO(167) GO(168) GO(169) GO(170) GO(171) \ + GO(172) GO(173) GO(174) GO(175) GO(176) GO(177) GO(178) GO(179) GO(180) \ + GO(181) GO(182) GO(183) GO(184) GO(185) GO(186) GO(187) GO(188) GO(189) \ + GO(190) GO(191) GO(192) GO(193) GO(194) GO(195) GO(196) GO(197) GO(198) \ + GO(199) GO(200) GO(201) GO(202) GO(203) GO(204) GO(205) GO(206) GO(207) \ + GO(208) GO(209) GO(210) GO(211) GO(212) GO(213) GO(214) GO(215) GO(216) \ + GO(217) GO(218) GO(219) GO(220) GO(221) GO(222) GO(223) GO(224) GO(225) \ + GO(226) GO(227) GO(228) GO(229) GO(230) GO(231) GO(232) GO(233) GO(234) \ + GO(235) GO(236) GO(237) GO(238) GO(239) GO(240) GO(241) GO(242) GO(243) \ + GO(244) GO(245) GO(246) GO(247) GO(248) GO(249) GO(250) GO(251) GO(252) \ + GO(253) GO(254) GO(255) -pop :: p (f s) -> Proxy s -pop _ = Proxy -{-# INLINE pop #-} +#define GO(n) \ + newtype CAT(T,n) = CAT(T,n) CAT(T,n); \ + instance B CAT(T,n) where { \ + reflectByte _ = n \ + }; +BYTES(GO) +#undef GO -twice :: p s -> Proxy (Twice s) -twice _ = Proxy +impossible :: a +impossible = error "Data.Reflection.reifyByte: impossible" -succTwice :: p s -> Proxy (SuccTwice s) -succTwice _ = Proxy +reifyByte :: Word8 -> (forall s. B s => Proxy s -> w) -> w +#ifdef __GLASGOW_HASKELL__ +reifyByte (W8# w) k = case w of { +#define GO(n) n## -> k (Proxy :: Proxy CAT(T,n)); +BYTES(GO) +#undef GO +_ -> impossible +} +#else +reifyByte w k = case w of { +#define GO(n) n -> k (Proxy :: Proxy CAT(T,n)); +BYTES(GO) +#undef GO +_ -> impossible +} +#endif -predTwice :: p s -> Proxy (PredTwice s) -predTwice _ = Proxy +class Reified s where + type Reflected s + reflect :: p s -> Reflected s -zero :: (Proxy Zero -> a) -> a -zero k = k Proxy +newtype Stable b0 b1 b2 b3 b4 b5 b6 b7 a = + Stable (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) -newtype Stable s a = Stable (Stable s a) +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 +{-# INLINE stable #-} stablePtrToIntPtr :: StablePtr a -> IntPtr stablePtrToIntPtr = ptrToIntPtr . castStablePtrToPtr +{-# INLINE stablePtrToIntPtr #-} intPtrToStablePtr :: IntPtr -> StablePtr a intPtrToStablePtr = castPtrToStablePtr . intPtrToPtr - -class Reified s where - type Reflected s - reflect :: p s -> Reflected s - -stable :: p s -> Proxy (Stable s a) -stable _ = Proxy - -unstable :: (p (Stable s a) -> a) -> Proxy s -unstable _ = Proxy +{-# INLINE intPtrToStablePtr #-} -instance ReifiedNum s => Reified (Stable s a) where - type Reflected (Stable s a) = a - reflect = r where - r = unsafePerformIO $ pure <$> deRefStablePtr p <* freeStablePtr p - p = intPtrToStablePtr $ reflectNum $ unstable r +instance (B b0, B b1, B b2, B b3, B b4, B b5, B b6, B b7) + => Reified (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) where + type Reflected (Stable b0 b1 b2 b3 b4 b5 b6 b7 a) = a + reflect = unsafePerformIO $ const <$> deRefStablePtr p <* freeStablePtr p where + p = intPtrToStablePtr $ + reflectByte (Proxy :: Proxy b0) .|. + (reflectByte (Proxy :: Proxy b1) `shiftL` 8) .|. + (reflectByte (Proxy :: Proxy b2) `shiftL` 16) .|. + (reflectByte (Proxy :: Proxy b3) `shiftL` 24) .|. + (reflectByte (Proxy :: Proxy b4) `shiftL` 32) .|. + (reflectByte (Proxy :: Proxy b5) `shiftL` 40) .|. + (reflectByte (Proxy :: Proxy b6) `shiftL` 48) .|. + (reflectByte (Proxy :: Proxy b7) `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 +-- 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 :: Reified s => (Proxy s -> b) -> proxy s -> b -reflectBefore f = let b = f Proxy in b `seq` const b +reflectBefore f = const $! f Proxy {-# NOINLINE reflectBefore #-} reify :: a -> (forall s. (Reified s, Reflected s ~ a) => Proxy s -> w) -> w -reify a k = unsafePerformIO $ do - p <- newStablePtr a - reifyIntegral (stablePtrToIntPtr p) (reflectBefore (fmap return k) . stable) -{-# NOINLINE reify #-} +reify a k = unsafeDupablePerformIO $ do + p <- newStablePtr a + let n = stablePtrToIntPtr p + reifyByte (fromIntegral n) $ \s0 -> + reifyByte (fromIntegral (n `shiftR` 8)) $ \s1 -> + reifyByte (fromIntegral (n `shiftR` 16)) $ \s2 -> + reifyByte (fromIntegral (n `shiftR` 24)) $ \s3 -> + reifyByte (fromIntegral (n `shiftR` 32)) $ \s4 -> + 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 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,10 @@ +reflection +========== + +This package provides an implementation of the ideas presented in the paper + + Oleg Kiselyov and Chung-Chieh Shan, "Functional Pearl: Implicit Configurations" + + +However, the API has been modified to use @Rank2Types@ and @TypeFamilies@ and the +implementation has been streamlined to improve performance. diff --git a/examples/Benchmark.hs b/examples/Benchmark.hs new file mode 100644 --- /dev/null +++ b/examples/Benchmark.hs @@ -0,0 +1,16 @@ +import Criterion.Main + +import qualified Data.Reflection as Old +import qualified Data.NewReflection as New + +old :: [Int] -> [Int] +old = map (\x -> Old.reify x Old.reflect) + +new :: [Int] -> [Int] +new = map (\x -> New.reify x New.reflect) + +main :: IO () +main = defaultMain + [ bench "old" $ nf old [1..100000] + , bench "new" $ nf new [1..100000] + ] diff --git a/reflection.cabal b/reflection.cabal --- a/reflection.cabal +++ b/reflection.cabal @@ -1,33 +1,32 @@ name: reflection -version: 0.8 +version: 0.9 license: BSD3 license-file: LICENSE author: Edward A. Kmett, Oleg Kiselyov and Chung-chieh Shan maintainer: Edward A. Kmett stability: experimental -homepage: http://www.cs.rutgers.edu/~ccshan/prepose/prepose.pdf +homepage: http://github.com/ekmett/reflection category: Data, Reflection, Dependent Types synopsis: Functional Pearl: Implicit Configurations -copyright: 2009 Edward A. Kmett, 2004 Oleg Kiselyov and Chung-chieh Shan +copyright: 2009-2012 Edward A. Kmett, + 2012 Elliott Hird, + 2004 Oleg Kiselyov and Chung-chieh Shan build-type: Simple -cabal-version: >= 1.6 +cabal-version: >= 1.10 description: This package provides an implementation of the ideas presented in the paper - "Functional Pearl: Implicit Configurations" by Oleg Kiselyov and - Chung-chieh Shan. However, the API has been modified to use @Rank2Types@ and - @TypeFamilies@ + \"Functional Pearl: Implicit Configurations\" by Oleg Kiselyov and + Chung-chieh Shan. However, the API has been modified to use @Rank2Types@ and @TypeFamilies@ and + the implementation has been streamlined to improve performance. . - Usage reduces to using two combinators. + The original paper can be obtained from . - > reify :: a -> (forall s. (Reified s, Reflected s ~ a) => Proxy s -> w) -> w - > reflect :: Reified s => p s -> Reflected s + /Changes in 0.9/: . - > ghci> reify 6 (\p -> reflect p + reflect p) :: Int - > 12 + * Faster internal implementation. . - The argument passed along by reify is just a @data Proxy t = Proxy@, so all of the - information needed to reconstruct your value has been moved to the type level. - This enables it to be used when constructing instances (See @examples/Monoid.hs@). + * Removed @ReifiedNum@, @reflectNum@, and @reifyIntegral@; @reify@ and @reflect@ are + considerably faster than the special case combinators were. . /Changes in 0.8/: . @@ -72,14 +71,22 @@ reduces the need for helper functions and scoped type variables in user code. -extra-source-files: examples/Monoid.hs examples/Constraints.hs +extra-source-files: + examples/Monoid.hs + examples/Constraints.hs + examples/Benchmark.hs + README source-repository head type: git location: git://github.com/ekmett/reflection.git library - other-extensions: Rank2Types, TypeFamilies + default-language: Haskell2010 + default-extensions: CPP + other-extensions: Rank2Types, TypeFamilies, ScopedTypeVariables + if impl(ghc) + other-extensions: MagicHash build-depends: base >= 4 && < 5, tagged >= 0.2.3 && < 0.3