derive-storable-plugin 0.1.0.2 → 0.2.0.0
raw patch · 26 files changed
+681/−24 lines, 26 filesdep +QuickCheckdep +criteriondep +deepseqdep ~basedep ~derive-storabledep ~ghcPVP ok
version bump matches the API change (PVP)
Dependencies added: QuickCheck, criterion, deepseq, derive-storable-plugin, ghc-paths, hspec
Dependency ranges changed: base, derive-storable, ghc, ghci
API changes (from Hackage documentation)
+ Foreign.Storable.Generic.Plugin.Internal.Helpers: eqTyVarBind :: TyVarBinder -> TyVarBinder -> Bool
Files
- ChangeLog.md +10/−0
- README.md +3/−1
- benchmark/Main.hs +145/−0
- benchmark/TestCases.hs +89/−0
- benchmark/TestCasesOptimized.hs +23/−0
- derive-storable-plugin.cabal +56/−2
- src/Foreign/Storable/Generic/Plugin/Internal.hs +3/−3
- src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs +21/−6
- src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs +18/−0
- src/Foreign/Storable/Generic/Plugin/Internal/Types.hs +63/−12
- test/ids/Concrete/Instances.hs +10/−0
- test/ids/Concrete/Main.hs +7/−0
- test/ids/Concrete/Types.hs +9/−0
- test/ids/Handwritten/Instances.hs +38/−0
- test/ids/Handwritten/Main.hs +7/−0
- test/ids/Handwritten/Types.hs +9/−0
- test/ids/NewType/Instances.hs +11/−0
- test/ids/NewType/Main.hs +7/−0
- test/ids/NewType/Types.hs +16/−0
- test/ids/ParametrisedSpec/Instances.hs +21/−0
- test/ids/ParametrisedSpec/Main.hs +10/−0
- test/ids/ParametrisedSpec/Types.hs +9/−0
- test/ids/ParametrisedSpec/Usage.hs +62/−0
- test/ids/TypeSynonym/Instances.hs +13/−0
- test/ids/TypeSynonym/Main.hs +7/−0
- test/ids/TypeSynonym/Types.hs +14/−0
ChangeLog.md view
@@ -1,5 +1,15 @@ # Revision history for generic-storable-plugin +## 0.2.0.0 -- 2017-11-04++* Support for GHC 8.2.*. +* Added benchmarks.++## 0.1.0.3 -- 2017-01-08++* Added tests.+* Added TravisCI builds.+ ## 0.1.0.2 -- 2016-09-11 * Changed generic-storable to derive-storable in README.md
README.md view
@@ -1,6 +1,8 @@ # Introduction -The goal of `derive-storable-plugin` is to support the [derive-storable](https://www.github.com/mkloczko/generic-storable) package. It introduces optimisations to GStorable methods derived using GHC.Generics at core-to-core passes. +[](https://travis-ci.org/mkloczko/derive-storable-plugin)++The goal of `derive-storable-plugin` is to support the [derive-storable](http://hackage.haskell.org/package/derive-storable) package. It introduces optimisations to GStorable methods derived using GHC.Generics at core-to-core passes. # Usage
+ benchmark/Main.hs view
@@ -0,0 +1,145 @@+{-#LANGUAGE TypeApplications #-}+{-#LANGUAGE AllowAmbiguousTypes #-}+{-#LANGUAGE ScopedTypeVariables #-}++import Criterion.Main+import Criterion.Types+import TestCases+import TestCasesOptimized+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array (mallocArray, peekArray, pokeArray)+import Foreign.Ptr+import Foreign.Storable+import Foreign.Storable.Generic+import Foreign.Storable.Generic.Internal++import GHC.Generics (from, to)++import GHC.Exts++import Control.DeepSeq+import Data.Proxy+++mallocFree :: forall a. (Storable a) => a -> IO ()+mallocFree a = do+ ptr <- mallocBytes $ (sizeOf a)+ free ptr++singularTests = +-- [ bgroup "mallocfree" $ +-- [ bgroup "Handwritten" $+-- [ bench "C1" $ nfIO (mallocFree c1hw_def)+-- , bench "C2" $ nfIO (mallocFree c2hw_def)+-- , bench "C3" $ nfIO (mallocFree c3hw_def)+-- , bench "C4" $ nfIO (mallocFree c4hw_def)+-- , bench "C5" $ nfIO (mallocFree c5hw_def)+-- ]+-- , bgroup "GStorable" $+-- [ bench "C1" $ nfIO (mallocFree c1_def)+-- , bench "C2" $ nfIO (mallocFree c2_def)+-- , bench "C3" $ nfIO (mallocFree c3_def)+-- , bench "C4" $ nfIO (mallocFree c4_def)+-- , bench "C5" $ nfIO (mallocFree c5_def)+-- ]+-- ]+ [ bgroup "sizeOf" $ + [ bgroup "Handwritten" $+ [ bench "C1" $ nf sizeOf c1hw_def+ , bench "C2" $ nf sizeOf c2hw_def+ , bench "C3" $ nf sizeOf c3hw_def+ , bench "C4" $ nf sizeOf c4hw_def+ , bench "C5" $ nf sizeOf c5hw_def+ ]+ + , bgroup "GStorable" $+ [ bench "C1" $ nf sizeOf c1_def+ , bench "C2" $ nf sizeOf c2_def+ , bench "C3" $ nf sizeOf c3_def+ , bench "C4" $ nf sizeOf c4_def+ , bench "C5" $ nf sizeOf c5_def+ ]+ , bgroup "Optimized" $+ [ bench "C1" $ nf sizeOf c1o_def+ , bench "C2" $ nf sizeOf c2o_def+ , bench "C3" $ nf sizeOf c3o_def+ , bench "C4" $ nf sizeOf c4o_def+ , bench "C5" $ nf sizeOf c5o_def+ ]+ ]+ , bgroup "alignment" $ + [ bgroup "Handwritten" $+ [ bench "C1" $ nf alignment c1hw_def+ , bench "C2" $ nf alignment c2hw_def+ , bench "C3" $ nf alignment c3hw_def+ , bench "C4" $ nf alignment c4hw_def+ , bench "C5" $ nf alignment c5hw_def+ ]+ , bgroup "GStorable" $+ [ bench "C1" $ nf alignment c1_def+ , bench "C2" $ nf alignment c2_def+ , bench "C3" $ nf alignment c3_def+ , bench "C4" $ nf alignment c4_def+ , bench "C5" $ nf alignment c5_def+ ]+ , bgroup "Optimized" $+ [ bench "C1" $ nf alignment c1o_def+ , bench "C2" $ nf alignment c2o_def+ , bench "C3" $ nf alignment c3o_def+ , bench "C4" $ nf alignment c4o_def+ , bench "C5" $ nf alignment c5o_def+ ]+ ]+ , bgroup "peek" $+ [ bgroup "Handwritten" $+ [ env (malloc @C1hw) $ \ptr -> bench "C1" $ nfIO (peek ptr)+ , env (malloc @C2hw) $ \ptr -> bench "C2" $ nfIO (peek ptr)+ , env (malloc @C3hw) $ \ptr -> bench "C3" $ nfIO (peek ptr)+ , env (malloc @C4hw) $ \ptr -> bench "C4" $ nfIO (peek ptr)+ , env (malloc @C5hw) $ \ptr -> bench "C5" $ nfIO (peek ptr)+ ]+ , bgroup "GStorable" $+ [ env (malloc @C1 ) $ \ptr -> bench "C1" $ nfIO (peek ptr)+ , env (malloc @C2 ) $ \ptr -> bench "C2" $ nfIO (peek ptr)+ , env (malloc @C3 ) $ \ptr -> bench "C3" $ nfIO (peek ptr)+ , env (malloc @C4 ) $ \ptr -> bench "C4" $ nfIO (peek ptr)+ , env (malloc @C5 ) $ \ptr -> bench "C5" $ nfIO (peek ptr)+ ]+ , bgroup "Optimized" $+ [ env (malloc @C1O ) $ \ptr -> bench "C1" $ nfIO ((gpeekByteOff ptr 0) :: IO C1O)+ , env (malloc @C2O ) $ \ptr -> bench "C2" $ nfIO ((gpeekByteOff ptr 0) :: IO C2O)+ , env (malloc @C3O ) $ \ptr -> bench "C3" $ nfIO (peek ptr)+ , env (malloc @C4O ) $ \ptr -> bench "C4" $ nfIO (peek ptr)+ , env (malloc @C5O ) $ \ptr -> bench "C5" $ nfIO (peek ptr)+ ]+ ] + , bgroup "poke" $+ [ bgroup "Handwritten" $ + [ env malloc $ \ptr -> bench "C1" $ nfIO (poke ptr c1hw_def) + , env malloc $ \ptr -> bench "C2" $ nfIO (poke ptr c2hw_def)+ , env malloc $ \ptr -> bench "C3" $ nfIO (poke ptr c3hw_def)+ , env malloc $ \ptr -> bench "C4" $ nfIO (poke ptr c4hw_def)+ , env malloc $ \ptr -> bench "C5" $ nfIO (poke ptr c5hw_def)+ ]+ , bgroup "GStorable" $+ [ env malloc $ \ptr -> bench "C1" $ nfIO (poke ptr c1_def) + , env malloc $ \ptr -> bench "C2" $ nfIO (poke ptr c2_def)+ , env malloc $ \ptr -> bench "C3" $ nfIO (poke ptr c3_def)+ , env malloc $ \ptr -> bench "C4" $ nfIO (poke ptr c4_def)+ , env malloc $ \ptr -> bench "C5" $ nfIO (poke ptr c5_def)+ ]+ , bgroup "Optimized" $+ [ env malloc $ \ptr -> bench "C1" $ nfIO (poke ptr c1o_def) + , env malloc $ \ptr -> bench "C2" $ nfIO (poke ptr c2o_def)+ , env malloc $ \ptr -> bench "C3" $ nfIO (poke ptr c3o_def)+ , env malloc $ \ptr -> bench "C4" $ nfIO (poke ptr c4o_def)+ , env malloc $ \ptr -> bench "C5" $ nfIO (poke ptr c5o_def)+ ]+ ]+ ]++++-- Our benchmark harness.+main = defaultMain $ singularTests+
+ benchmark/TestCases.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module TestCases where ++import GHC.Generics (Generic)+import Foreign.Storable.Generic+import Data.Int+import Control.DeepSeq+++data C1 = C1 Int32 deriving (Show, Generic, GStorable, NFData)+data C2 = C2 Int8 Int32 Int16 deriving (Show, Generic, GStorable, NFData)+data C3 = C3 C2 Int64 C1 deriving (Show, Generic, GStorable, NFData)+data C4 = C4 Double Int8 C3 deriving (Show, Generic, GStorable, NFData)+data C5 = C5 Int32 C2 C4 deriving (Show, Generic, GStorable, NFData)++c1_def = C1 3+c2_def = C2 3 10 8+c3_def = C3 c2_def 11000 c1_def+c4_def = C4 0.312 3 c3_def +c5_def = C5 100 c2_def c4_def +++data C1hw = C1hw Int32 deriving (Show,Generic, NFData)+data C2hw = C2hw Int8 Int32 Int16 deriving (Show,Generic, NFData)+data C3hw = C3hw C2hw Int64 C1hw deriving (Show,Generic, NFData)+data C4hw = C4hw Double Int8 C3hw deriving (Show,Generic, NFData)+data C5hw = C5hw Int32 C2hw C4hw deriving (Show,Generic, NFData)++c1hw_def = C1hw 3+c2hw_def = C2hw 3 10 8+c3hw_def = C3hw c2hw_def 11000 c1hw_def+c4hw_def = C4hw 0.312 3 c3hw_def +c5hw_def = C5hw 100 c2hw_def c4hw_def ++instance Storable C1hw where+ sizeOf _ = 4+ alignment _ = 4+ peekByteOff ptr off = C1hw <$> (peekByteOff ptr off :: IO Int32) + pokeByteOff ptr off (C1hw v) = pokeByteOff ptr off v++instance Storable C2hw where+ sizeOf _ = 12+ alignment _ = 4+ peekByteOff ptr off = C2hw + <$> (peekByteOff ptr off :: IO Int8 ) + <*> (peekByteOff ptr (off + 4) :: IO Int32) + <*> (peekByteOff ptr (off + 8) :: IO Int16) + + pokeByteOff ptr off (C2hw i8a i32 i16) = do+ pokeByteOff ptr off i8a+ pokeByteOff ptr (off + 4) i32+ pokeByteOff ptr (off + 8) i16++instance Storable C3hw where+ sizeOf _ = 32+ alignment _ = 8+ peekByteOff ptr off = C3hw + <$> (peekByteOff ptr off :: IO C2hw ) + <*> (peekByteOff ptr (off + 16) :: IO Int64) + <*> (peekByteOff ptr (off + 24) :: IO C1hw) + + pokeByteOff ptr off (C3hw c2hw i64 c1hw) = do+ pokeByteOff ptr off c2hw+ pokeByteOff ptr (off + 16) i64+ pokeByteOff ptr (off + 24) c1hw++instance Storable C4hw where+ sizeOf _ = 48+ alignment _ = 8+ peekByteOff ptr off = C4hw + <$> (peekByteOff ptr off :: IO Double)+ <*> (peekByteOff ptr (off + 8) :: IO Int8 )+ <*> (peekByteOff ptr (off + 16) :: IO C3hw )+ pokeByteOff ptr off (C4hw dbl i8 c3hw) = do+ pokeByteOff ptr off dbl+ pokeByteOff ptr (off + 8) i8+ pokeByteOff ptr (off + 16) c3hw++instance Storable C5hw where + sizeOf _ = 64+ alignment _ = 8+ peekByteOff ptr off = C5hw + <$> (peekByteOff ptr off :: IO Int32)+ <*> (peekByteOff ptr (off + 4 ) :: IO C2hw )+ <*> (peekByteOff ptr (off + 16) :: IO C4hw )+ pokeByteOff ptr off (C5hw i32 c2hw c4hw) = do+ pokeByteOff ptr off i32+ pokeByteOff ptr (off + 4) c2hw+ pokeByteOff ptr (off + 16) c4hw
+ benchmark/TestCasesOptimized.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}+{-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-crash #-} +{-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-v2 #-} +module TestCasesOptimized where ++import GHC.Generics (Generic)+import Foreign.Storable.Generic+import Data.Int+import Control.DeepSeq+++data C1O = C1O Int32 deriving (Show, Generic, GStorable, NFData)+data C2O = C2O Int8 Int32 Int16 deriving (Show, Generic, GStorable, NFData)+data C3O = C3O C2O Int64 C1O deriving (Show, Generic, GStorable, NFData)+data C4O = C4O Double Int8 C3O deriving (Show, Generic, GStorable, NFData)+data C5O = C5O Int32 C2O C4O deriving (Show, Generic, GStorable, NFData)++c1o_def = C1O 3+c2o_def = C2O 3 10 8+c3o_def = C3O c2o_def 11000 c1o_def+c4o_def = C4O 0.312 3 c3o_def +c5o_def = C5O 100 c2o_def c4o_def
derive-storable-plugin.cabal view
@@ -2,7 +2,7 @@ -- further documentation, see http://haskell.org/cabal/users-guide/ name: derive-storable-plugin-version: 0.1.0.2+version: 0.2.0.0 synopsis: GHC core plugin supporting the derive-storable package. description: The package helps derive-storable package in forcing compile time evaluation of sizes, alignments and offsets.@@ -16,6 +16,7 @@ build-type: Simple extra-source-files: ChangeLog.md README.md cabal-version: >=1.10+tested-with: GHC==8.0.1, GHC==8.0.2, GHC==8.2.1 library exposed-modules: Foreign.Storable.Generic.Plugin@@ -28,6 +29,59 @@ , Foreign.Storable.Generic.Plugin.Internal.Types -- other-modules: other-extensions: DeriveGeneric, DeriveAnyClass, PatternGuards- build-depends: base >=4.9 && <4.10, ghc >= 8.0 && <8.1, ghci >=8.0 && <8.1, derive-storable + build-depends: base >=4.9 && <4.11, ghc >= 8.0 && <8.3, ghci >= 8.0 && <8.3, derive-storable == 0.1.1.* hs-source-dirs: src default-language: Haskell2010++benchmark plugin-benchmark+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmark/+ default-language: Haskell2010+ other-modules: TestCases, TestCasesOptimized+ Main-is: Main.hs+ build-depends: base >= 4.9 && < 4.11, deepseq, criterion >= 1.1.0+ , derive-storable, derive-storable-plugin+test-suite ids-concrete+ type: exitcode-stdio-1.0+ hs-source-dirs: test/ids/Concrete+ default-language: Haskell2010+ other-modules: Types, Instances+ Main-is: Main.hs+ build-depends: base >= 4.9 && < 4.11, ghc >= 8.0 && <8.3, ghci >= 8.0 && <8.3, ghc-paths+ , derive-storable, derive-storable-plugin, hspec >= 2.4, QuickCheck >= 2.10++test-suite ids-handwritten+ type: exitcode-stdio-1.0+ hs-source-dirs: test/ids/Handwritten+ default-language: Haskell2010+ other-modules: Types, Instances+ Main-is: Main.hs+ build-depends: base >= 4.9 && < 4.11, ghc >= 8.0 && <8.3, ghci >= 8.0 && <8.3, ghc-paths+ , derive-storable, derive-storable-plugin, hspec >= 2.4, QuickCheck >= 2.10++test-suite ids-newtype+ type: exitcode-stdio-1.0+ hs-source-dirs: test/ids/NewType+ default-language: Haskell2010+ other-modules: Types, Instances+ Main-is: Main.hs+ build-depends: base >= 4.9 && < 4.11, ghc >= 8.0 && <8.3, ghci >= 8.0 && <8.3, ghc-paths+ , derive-storable, derive-storable-plugin, hspec >= 2.4, QuickCheck >= 2.10++test-suite ids-parametrised-spec+ type: exitcode-stdio-1.0+ hs-source-dirs: test/ids/ParametrisedSpec+ default-language: Haskell2010+ other-modules: Types, Instances, Usage+ Main-is: Main.hs+ build-depends: base >= 4.9 && < 4.11, ghc >= 8.0 && <8.3, ghci >= 8.0 && <8.3, ghc-paths+ , derive-storable, derive-storable-plugin, hspec >= 2.4, QuickCheck >= 2.10++test-suite ids-typesynonym+ type: exitcode-stdio-1.0+ hs-source-dirs: test/ids/TypeSynonym+ default-language: Haskell2010+ other-modules: Types, Instances+ Main-is: Main.hs+ build-depends: base >= 4.9 && < 4.11, ghc >= 8.0 && <8.3, ghci >= 8.0 && <8.3, ghc-paths+ , derive-storable, derive-storable-plugin, hspec >= 2.4, QuickCheck >= 2.10
src/Foreign/Storable/Generic/Plugin/Internal.hs view
@@ -120,7 +120,7 @@ let binds = mg_binds guts -- Get GStorable ids that are fully defined. all_ids = concatMap getIdsBind binds- with_typecheck = withTypeCheck getGStorableType isGStorableId + with_typecheck = withTypeCheck getGStorableType isGStorableId predicate id = and [ with_typecheck id , not (hasGStorableConstraints $ varType id) ]@@ -138,7 +138,7 @@ type_list = [ t | Just t <- m_gstorable_types] -- Calculate the type ordering. (type_order,m_error) = calcGroupOrder type_list- + groupTypes_info flags type_order groupTypes_errors flags bad_types @@ -236,7 +236,7 @@ (nonrecs, recs) = partition isNonRecBind gstorable_binds -- Group the gstorables by nestedness (grouped_binds, m_err_group) = groupBinds type_hierarchy nonrecs- + foundBinds_info flags $ concatMap getIdsBind $ concat grouped_binds -- Check for errors not_grouped <- grouping_errors flags m_err_group
src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs view
@@ -39,10 +39,11 @@ where -- Management of Core.-import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt, AltCon(..))+import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt, AltCon(..), isId, Unfolding(..)) import Literal (Literal(..))-import Id (isLocalId, isGlobalId,Id)-import Var (Var(..))+import Id (isLocalId, isGlobalId,setIdInfo,Id)+import IdInfo (IdInfo(..))+import Var (Var(..), idInfo) import Name (getOccName,mkOccName, getSrcSpan) import OccName (OccName(..), occNameString) import qualified Name as N (varName, tvName, tcClsName)@@ -162,7 +163,7 @@ Left err@(CompilationError _ _) -> Left $ CompilationError b (pprError Some err) a -> a- + return $ NonRec id <$> e_subs @@ -367,7 +368,8 @@ e_new_s <- exprToIntVal x_id new_case_expr case e_new_s of Left err -> return $ Left err- Right int_val -> offsetSubstitutionTree (int_val:scope) alt_expr + Right int_val -> offsetSubstitutionTree (int_val:scope) alt_expr + -- Normal case expressions. | Case case_expr cb t alts <- expr = do@@ -419,6 +421,19 @@ -- Everything else - nope. | otherwise = return $ Left $ CompilationNotSupported core_bind +-- | Put the expression back into the unfolding core expr.+replaceUnfoldingBind :: CoreBind -> CoreBind+replaceUnfoldingBind b@(NonRec id expr)+ | NonRec id expr <- b+ , isId id+ , id_info <- idInfo id+ , unfolding <- unfoldingInfo id_info+ , _ <- uf_tmpl+ = NonRec (setIdInfo id $ id_info {unfoldingInfo = unfolding{uf_tmpl = expr} } ) expr+ | otherwise + = b+ + -- | Lint a binding lintBind :: CoreBind -- ^ Core binding to use when returning CompilationError -> CoreBind -- ^ Core binding to check@@ -509,7 +524,7 @@ e_compiled <- compileGStorableBind bind -- Monad transformers would be nice here. case e_compiled of- Right bind' -> lintBind bind bind'+ Right bind' -> lintBind bind (replaceUnfoldingBind bind') _ -> return e_compiled -- Compiled (or not) expressions e_compiled <- mapM compile_and_lint layer_replaced
src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs view
@@ -9,6 +9,7 @@ Various helping functions. -}+{-#LANGUAGE CPP#-} module Foreign.Storable.Generic.Plugin.Internal.Helpers where -- Management of Core.@@ -16,6 +17,9 @@ import Literal (Literal(..)) import Id (isLocalId, isGlobalId,Id) import Var (Var(..))+#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+import Var (TyVarBndr(..), TyVarBinder)+#endif import Name (getOccName,mkOccName) import OccName (OccName(..), occNameString) import qualified Name as N (varName)@@ -97,15 +101,29 @@ eqType (TyVarTy v1) (TyVarTy v2) = v1 == v2 eqType (AppTy t1a t1b) (AppTy t2a t2b) = t1a `eqType` t2a && t1b `eqType` t2b eqType (TyConApp tc1 ts1) (TyConApp tc2 ts2) = tc1 == tc2 && (and $ zipWith eqType ts1 ts2)+#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+eqType (ForAllTy tb1 t1) (ForAllTy tb2 t2) = tb1 `eqTyVarBind` tb2 && t1 `eqType` t2+#else eqType (ForAllTy tb1 t1) (ForAllTy tb2 t2) = tb1 `eqTyBind` tb2 && t1 `eqType` t2+#endif -- Not dealing with type coercions or casts. eqType _ _ = False -- | Equality for type binders eqTyBind :: TyBinder -> TyBinder -> Bool+#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+eqTyBind (Named tvb1) (Named tvb2) = tvb1 `eqTyVarBind` tvb2+#else eqTyBind (Named t1 vis1) (Named t2 vis2) = t1 == t2 && vis1 == vis2+#endif eqTyBind (Anon t1) (Anon t2) = t1 `eqType` t2 eqTyBind _ _ = False++#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+-- | Equality for type variable binders+eqTyVarBind :: TyVarBinder -> TyVarBinder -> Bool+eqTyVarBind (TvBndr t1 arg1) (TvBndr t2 arg2) = t1 == t2 +#endif -- | 'elem' function for types elemType :: Type -> [Type] -> Bool
src/Foreign/Storable/Generic/Plugin/Internal/Types.hs view
@@ -9,6 +9,7 @@ Functions for obtaining types from GStorable methods and instances. -}+{-#LANGUAGE CPP #-} module Foreign.Storable.Generic.Plugin.Internal.Types ( -- Type predicates@@ -40,7 +41,10 @@ import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt) import Literal (Literal(..)) import Id (isLocalId, isGlobalId,Id)-import Var (Var(..))+import Var (Var(..), isId)+#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+import Var (TyVarBndr(..), TyVarBinder, binderVar)+#endif import Name (getOccName,mkOccName) import OccName (OccName(..), occNameString) import qualified Name as N (varName,tcClsName)@@ -98,6 +102,7 @@ isPtrType (TyConApp ptr [el]) = getUnique ptr == ptrTyConKey isPtrType _ = False + -- | Check whether the type is a IO. isIOType :: Type -> Bool isIOType (TyConApp io [el]) = isIOTyCon io@@ -125,6 +130,11 @@ isRealWorldTyCon :: TyCon -> Bool isRealWorldTyCon rw = getUnique rw == realWorldTyConKey +-- | Check whether the type is a State# RealWorld.+isStateRealWorld :: Type -> Bool+isStateRealWorld t@(TyConApp st [rl]) = isStatePrimType t && isRealWorldType rl+isStateRealWorld _ = False+ -- | Check whether the type constuctor is a GStorable isGStorableInstTyCon :: TyCon -> Bool isGStorableInstTyCon tc = getOccName (tyConName tc) == mkOccName N.tcClsName "GStorable" @@ -142,7 +152,12 @@ hasGStorableConstraints :: Type -> Bool hasGStorableConstraints t | ForAllTy bind next <- t+#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+ , isId $ binderVar bind+ , gstorable_cons <- varType $ binderVar bind+#else , Anon gstorable_cons <- bind+#endif , hasConstraintKind gstorable_cons , TyConApp gstorable_tc [_] <- gstorable_cons , isGStorableInstTyCon gstorable_tc@@ -168,9 +183,15 @@ getAlignmentType t -- Assuming there are no anonymous ty bind between -- the type and the integer, ie no : Type -> forall a. Int+#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+ | FunTy t1 t2 <- t+ , isIntType t2+ , the_t <- t1+#else | ForAllTy ty_bind int_t <- t- , isIntType int_t + , isIntType int_t , Anon the_t <- ty_bind+#endif = Just the_t | ForAllTy _ some_t <- t = getAlignmentType some_t | otherwise = Nothing@@ -180,20 +201,26 @@ getSizeType t -- Assuming there are no anonymous ty bind between -- the type and the integer, ie no : Type -> forall a. Int+#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+ | FunTy t1 t2 <- t+ , isIntType t2+ , the_t <- t1+#else | ForAllTy ty_bind int_t <- t- , isIntType int_t + , isIntType int_t , Anon the_t <- ty_bind+#endif = Just the_t | ForAllTy _ some_t <- t = getSizeType some_t | otherwise = Nothing ++ -- | Get the type from GStorable peek method getPeekType :: Type -> Maybe Type getPeekType t = getPeekType' t False False -- -- | Insides of getPeekType, which takes into the account -- the order of arguments. getPeekType' :: Type @@ -208,15 +235,24 @@ = Just the_t -- Int -> IO (TheType) | after_ptr+#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+ , FunTy int_t io_t <- t+#else , ForAllTy ty_bind io_t <- t , Anon int_t <- ty_bind+#endif , isIntType int_t = getPeekType' io_t True True -- Ptr b -> Int -> IO (TheType)- | ForAllTy ty_bind int_t <- t+#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+ | ForAllTy ty_bind fun_t <- t+ , FunTy ptr_t rest <- fun_t +#else+ | ForAllTy ty_bind rest <- t , Anon ptr_t <- ty_bind+#endif , isPtrType ptr_t- = getPeekType' int_t True False+ = getPeekType' rest True False -- Ignore other types -- including constraints and -- Named ty binders.@@ -225,12 +261,13 @@ | otherwise = Nothing ++--isUnboxedTuple2 is State# h + -- | Get the type from GStorable poke method getPokeType :: Type -> Maybe Type getPokeType t = getPokeType' t False False -- getPokeType' :: Type -> Bool -- ^ Is after Ptr -> Bool -- ^ Is after Int@@ -238,21 +275,35 @@ getPokeType' t after_ptr after_int -- Last step: TheType -> IO () | after_ptr, after_int+#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+ , FunTy the_t io_t <- t+ , isIOType io_t+#else , ForAllTy ty_bind io_t <- t , isIOType io_t- , Anon the_t <- ty_bind+ , Anon the_t <- ty_bind+#endif = Just the_t -- Int -> TheType -> IO () | after_ptr+#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+ , FunTy int_t rest <- t+#else , ForAllTy ty_bind rest <- t , Anon int_t <- ty_bind+#endif , isIntType int_t = getPokeType' rest True True -- Ptr b -> Int -> TheType -> IO ()- | ForAllTy ty_bind int_rest <- t+#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+ | ForAllTy ty_bind fun_t <- t+ , FunTy ptr_t rest <- fun_t+#else+ | ForAllTy ty_bind rest <- t , Anon ptr_t <- ty_bind+#endif , isPtrType ptr_t- = getPokeType' int_rest True False+ = getPokeType' rest True False -- Ignore other types -- including constraints and -- Named ty binders.
+ test/ids/Concrete/Instances.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}+{-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-crash #-} +module Instances where++import Types+import Foreign.Storable.Generic++instance GStorable Flat+instance GStorable Nested+instance GStorable Nested2
+ test/ids/Concrete/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import Types+import Instances++main :: IO ()+main = return ()
+ test/ids/Concrete/Types.hs view
@@ -0,0 +1,9 @@+{-#LANGUAGE DeriveGeneric #-}++module Types where++import GHC.Generics++data Flat = Flat Int Double deriving (Generic)+data Nested = Nested Flat deriving (Generic)+data Nested2 = Nested2 Nested deriving (Generic)
+ test/ids/Handwritten/Instances.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}+{-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-crash #-} ++module Instances where++import Types+import Foreign.Storable.Generic+++instance GStorable Flat where+ gsizeOf _ = 16+ galignment _ = 8+ gpeekByteOff ptr offset = Flat + <$> gpeekByteOff ptr offset+ <*> gpeekByteOff ptr (offset+8)+ gpokeByteOff ptr offset (Flat a b) = + gpokeByteOff ptr offset a+ >> gpokeByteOff ptr (offset+8) b++instance GStorable Nested where + gsizeOf _ = 16+ galignment _ = 8+ gpeekByteOff ptr offset = Nested <$> (Flat + <$> gpeekByteOff ptr offset+ <*> gpeekByteOff ptr (offset+8))+ gpokeByteOff ptr offset (Nested (Flat a b)) = + gpokeByteOff ptr offset a+ >> gpokeByteOff ptr (offset+8) b++instance GStorable Nested2 where+ gsizeOf _ = 16+ galignment _ = 8+ gpeekByteOff ptr offset = Nested2 <$> (Nested <$> (Flat + <$> gpeekByteOff ptr offset+ <*> gpeekByteOff ptr (offset+8)))+ gpokeByteOff ptr offset (Nested2 (Nested (Flat a b))) = + gpokeByteOff ptr offset a+ >> gpokeByteOff ptr (offset+8) b
+ test/ids/Handwritten/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import Types+import Instances++main :: IO ()+main = return ()
+ test/ids/Handwritten/Types.hs view
@@ -0,0 +1,9 @@+{-#LANGUAGE DeriveGeneric #-}++module Types where++import GHC.Generics++data Flat = Flat Int Double deriving (Generic)+data Nested = Nested Flat deriving (Generic)+data Nested2 = Nested2 Nested deriving (Generic)
+ test/ids/NewType/Instances.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}+{-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-crash #-} ++module Instances where++import Types+import Foreign.Storable.Generic++instance GStorable NFlat+instance GStorable NNested+instance GStorable NNested2
+ test/ids/NewType/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import Types+import Instances++main :: IO ()+main = return ()
+ test/ids/NewType/Types.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}++module Types where++import GHC.Generics+import Foreign.Storable.Generic++data Flat = Flat Int Double deriving (Generic, GStorable)+data Nested = Nested Flat deriving (Generic, GStorable) +data Nested2 = Nested2 Nested deriving (Generic, GStorable)++newtype NFlat = NFlat Flat deriving (Generic)+newtype NNested = NNested Nested deriving (Generic)+newtype NNested2 = NNested2 Nested2 deriving (Generic)+
+ test/ids/ParametrisedSpec/Instances.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}+{-# LANGUAGE FlexibleInstances #-}+module Instances where++import Types+import Foreign.Storable.Generic+import Foreign.Ptr ++instance (GStorable a, GStorable b) => GStorable (Flat a b) where {+ {-# SPECIALIZE instance GStorable (Flat Int Double) #-};+ {-# SPECIALIZE instance GStorable (Flat Float Double) #-}+}+instance (GStorable a, GStorable b) => GStorable (Nested a b) where {+ {-# SPECIALIZE instance GStorable (Nested Int Double) #-};+ {-# SPECIALIZE instance GStorable (Nested Word Char) #-}+}+instance (GStorable a, GStorable b) => GStorable (Nested2 a b) where {+ {-# SPECIALIZE instance GStorable (Nested2 Int Double) #-};+ {-# SPECIALIZE instance GStorable (Nested2 Float Float) #-}+}+--instance (GStorable a, GStorable b) => GStorable (Nested2 a b)
+ test/ids/ParametrisedSpec/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import Types+import Instances+import Usage ++import Foreign.Ptr++main :: IO ()+main = flatPeekByteOff nullPtr 0 >> return ()
+ test/ids/ParametrisedSpec/Types.hs view
@@ -0,0 +1,9 @@+{-#LANGUAGE DeriveGeneric #-}++module Types where++import GHC.Generics++data Flat a b = Flat a b deriving (Generic)+data Nested a b = Nested a (Flat a b) deriving (Generic)+data Nested2 a b = Nested2 b (Nested a b) deriving (Generic)
+ test/ids/ParametrisedSpec/Usage.hs view
@@ -0,0 +1,62 @@+{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}+module Usage where++import Types+import Instances++import Foreign.Storable.Generic+import Foreign.Ptr+import Foreign.Marshal.Alloc++import GHC.Exts+----------+-- Flat --+----------++flatSizeOf :: Flat Int Double -> Int+flatSizeOf = gsizeOf++flatAlignment :: Flat Int Double -> Int+flatAlignment = galignment+++flatPeekByteOff :: Ptr b -> Int -> IO (Flat Int Double)+flatPeekByteOff = gpeekByteOff++++-- flatPokeByteOff :: Ptr b -> Int -> Flat Int Double -> IO ()+-- flatPokeByteOff = gpokeByteOff+++-- ------------+-- -- Nested --+-- ------------+-- +-- nestedSizeOf :: Nested Int Double -> Int+-- nestedSizeOf = gsizeOf+-- +-- nestedAlignment :: Nested Int Double -> Int+-- nestedAlignment = galignment+-- +-- nestedPeekByteOff :: Ptr b -> Int -> IO (Nested Int Double)+-- nestedPeekByteOff = gpeekByteOff+-- +-- -- nestedPokeByteOff :: Ptr b -> Int -> Nested Int Double -> IO ()+-- -- nestedPokeByteOff = gpokeByteOff+-- +-- --------------+-- -- Nested 2 --+-- --------------+-- +-- nested2SizeOf :: Nested2 Int Double -> Int+-- nested2SizeOf = gsizeOf+-- +-- nested2Alignment :: Nested2 Int Double -> Int+-- nested2Alignment = galignment+-- +-- nested2PeekByteOff :: Ptr b -> Int -> IO (Nested2 Int Double)+-- nested2PeekByteOff = gpeekByteOff+-- +-- -- nested2PokeByteOff :: Ptr b -> Int -> Nested2 Int Double -> IO ()+-- -- nested2PokeByteOff = gpokeByteOff
+ test/ids/TypeSynonym/Instances.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}+{-# OPTIONS_GHC -fplugin-opt=Foreign.Storable.Generic.Plugin:-crash #-} ++{-# LANGUAGE FlexibleInstances #-}+module Instances where++import Types+import Foreign.Storable.Generic++instance GStorable Flat +instance GStorable Flat2+instance GStorable Nested +instance GStorable Nested2
+ test/ids/TypeSynonym/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import Types+import Instances++main :: IO ()+main = return ()
+ test/ids/TypeSynonym/Types.hs view
@@ -0,0 +1,14 @@+{-#LANGUAGE DeriveGeneric #-}++module Types where++import GHC.Generics++data Flat = Flat Int Double deriving (Generic)+data Flat2 = Flat2 Double Char deriving (Generic)+data Nested = Nested Flat Flat2 deriving (Generic)+data Nested2 = Nested2 Nested deriving (Generic)++type TFlat = Flat +type TNested = Nested +type TNested2 = Nested2