derive-storable-plugin (empty) → 0.1.0.0
raw patch · 12 files changed
+1870/−0 lines, 12 filesdep +basedep +derive-storabledep +ghcsetup-changed
Dependencies added: base, derive-storable, ghc, ghci
Files
- ChangeLog.md +5/−0
- LICENSE +20/−0
- Setup.hs +2/−0
- derive-storable-plugin.cabal +32/−0
- src/Foreign/Storable/Generic/Plugin.hs +116/−0
- src/Foreign/Storable/Generic/Plugin/Internal.hs +246/−0
- src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs +558/−0
- src/Foreign/Storable/Generic/Plugin/Internal/Error.hs +159/−0
- src/Foreign/Storable/Generic/Plugin/Internal/GroupTypes.hs +165/−0
- src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs +113/−0
- src/Foreign/Storable/Generic/Plugin/Internal/Predicates.hs +175/−0
- src/Foreign/Storable/Generic/Plugin/Internal/Types.hs +279/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for generic-storable-plugin++## 0.1.0.0 -- 2016-09-08++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2016 Mateusz Kłoczko++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ derive-storable-plugin.cabal view
@@ -0,0 +1,32 @@+-- Initial generic-storable-plugin.cabal generated by cabal init. For +-- further documentation, see http://haskell.org/cabal/users-guide/++name: derive-storable-plugin+version: 0.1.0.0+synopsis: GHC core plugin supporting the generic-storable package.+-- description: +homepage: https://www.github.com/mkloczko/generic-storable-plugin/+license: MIT+license-file: LICENSE+author: Mateusz Kłoczko+maintainer: mateusz.p.kloczko@gmail.com+-- copyright: +category: Foreign+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++library+ exposed-modules: Foreign.Storable.Generic.Plugin+ , Foreign.Storable.Generic.Plugin.Internal+ , Foreign.Storable.Generic.Plugin.Internal.Error+ , Foreign.Storable.Generic.Plugin.Internal.Compile+ , Foreign.Storable.Generic.Plugin.Internal.GroupTypes+ , Foreign.Storable.Generic.Plugin.Internal.Helpers+ , Foreign.Storable.Generic.Plugin.Internal.Predicates+ , 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 + hs-source-dirs: src+ default-language: Haskell2010
+ src/Foreign/Storable/Generic/Plugin.hs view
@@ -0,0 +1,116 @@+{-|+Module : Foreign.Storable.Generic.Plugin+Copyright : (c) Mateusz Kłoczko, 2016+License : MIT+Maintainer : mateusz.p.kloczko@gmail.com+Stability : experimental+Portability : GHC-only++GHC Core plugin for optimising GStorable instances. +For more information please refer to generic-storable package.++How to enable:++ * use @-fplugin Foreign.Storable.Generic.Plugin@ option+ * add @\{\-\# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin \#\-\}@ to the compiled module.++-}+module Foreign.Storable.Generic.Plugin (plugin) where++import GhcPlugins++import Data.Maybe++import Foreign.Storable.Generic.Plugin.Internal+import Data.IORef+import Data.List+import Control.Monad (when)++import Foreign.Storable.Generic.Plugin.Internal.Error++-- | The plugin itself.+plugin :: Plugin+plugin = defaultPlugin {+ installCoreToDos = install+ }++defFlags = Flags Some False+++orderingPass :: Flags -> IORef [[Type]] -> CoreToDo+orderingPass flags io_ref = CoreDoPluginPass "GStorable - type ordering" + (groupTypes flags io_ref)++substitutionPass :: Flags -> IORef [[Type]] -> CoreToDo+substitutionPass flags io_ref = CoreDoPluginPass "GStorable - substitution" + (gstorableSubstitution flags io_ref)++-- | Checks whether the core pass is a simplifier phase 0.+isPhase0 :: CoreToDo + -> Bool+isPhase0 (CoreDoSimplify iters simpl_mode) = case sm_phase $ simpl_mode of+ Phase 0 -> True+ _ -> False +isPhase0 _ = False++-- | Return the index of simplifier phase 0. +afterPhase0 :: [CoreToDo] -> Maybe Int+afterPhase0 todos = findIndex isPhase0 todos ++-- | Checks whether the core pass is a specialising pass.+isSpecialize :: CoreToDo -> Bool+isSpecialize CoreDoSpecialising = True+isSpecialize _ = False++-- | Return the index of the specialising pass. +afterSpecialize :: [CoreToDo] -> Maybe Int+afterSpecialize todos = findIndex isSpecialize todos ++-- | Set the verbosity and ToCrash flags based on supplied arguments.+setOpts :: Flags -> String -> Flags+setOpts (Flags _ crash) "-v0" = Flags None crash+setOpts (Flags _ crash) "-v1" = Flags Some crash+setOpts (Flags _ crash) "-v2" = Flags All crash+setOpts (Flags verb _ ) "-crash" = Flags verb True+setOpts flags opt = flags++-- | Parse command line options.+parseOpts :: [CommandLineOption] -> Flags+parseOpts opts = foldl' setOpts defFlags opts+++putPasses :: Flags -> [CoreToDo] -> Int -> Int -> CoreM [CoreToDo] +putPasses flags todos ph0 sp = do+ the_ioref <- liftIO $ newIORef []+ let (before_spec,after_spec) = splitAt sp todos+ (before_ph0 ,after_ph0) = splitAt (ph0-sp) after_spec+ ordering = orderingPass flags the_ioref+ substitute = substitutionPass flags the_ioref+ new_todos = concat [before_spec, [ordering], before_ph0, [substitute] , after_ph0]+ return new_todos++-- | Inform about installation errors.+install_err :: Flags -> CoreM ()+install_err flags = do+ let (Flags verb to_crash) = flags+ printer = case verb of+ None -> return ()+ other -> putMsg $ text "The GStorable plugin requires simplifier phases with inlining and rules on, as well as a specialiser phase."+ $$ text "Try to compile the code with -O1 or -O2 optimisation flags." + printer+ when to_crash $ (return $ error "Crashing...")+ +++install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]+install opts todos = do+ dyn_flags <- getDynFlags+ let opt_level = optLevel dyn_flags + flags = parseOpts opts+ m_phase0 = afterPhase0 todos+ m_spec = afterSpecialize todos++ case (m_phase0, m_spec, opt_level) of+ (_ ,_ ,0) -> install_err flags >> return todos+ (Just ph0, Just sp,_) -> putPasses flags todos (ph0+1) (sp+1)+ (_ ,_ ,_) -> install_err flags >> return todos
+ src/Foreign/Storable/Generic/Plugin/Internal.hs view
@@ -0,0 +1,246 @@+{-|+Module : Foreign.Storable.Generic.Plugin.Internal+Copyright : (c) Mateusz Kłoczko, 2016+License : MIT+Maintainer : mateusz.p.kloczko@gmail.com+Stability : experimental+Portability : GHC-only++Contains methods for calculating type ordering and performing the compile-substitution optimisation.++-}++module Foreign.Storable.Generic.Plugin.Internal + ( groupTypes+ , gstorableSubstitution)+where++-- Management of Core.+import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt)+import Literal (Literal(..))+import Id (isLocalId, isGlobalId,Id, modifyInlinePragma, setInlinePragma, idInfo)+import IdInfo +import Var (Var(..))+import Name (getOccName,mkOccName)+import OccName (OccName(..), occNameString)+import qualified Name as N (varName)+import SrcLoc (noSrcSpan)+import Unique (getUnique)+-- Compilation pipeline stuff+import HscMain (hscCompileCoreExpr)+import HscTypes (HscEnv,ModGuts(..))+import CoreMonad + (CoreM, SimplifierMode(..), CoreToDo(..), + getHscEnv, getDynFlags, putMsg, putMsgS)+import BasicTypes (CompilerPhase(..))+-- Haskell types +import Type (isAlgType, splitTyConApp_maybe)+import TyCon (tyConKind, algTyConRhs, visibleDataCons)+import TyCoRep (Type(..), TyBinder(..))+import TysWiredIn (intDataCon)+import DataCon (dataConWorkId,dataConOrigArgTys) ++import MkCore (mkWildValBinder)+-- Printing+import Outputable + (cat, ppr, SDoc, showSDocUnsafe, showSDoc, + ($$), ($+$), hsep, vcat, empty,text, + (<>), (<+>), nest, int, colon,hcat, comma, + punctuate, fsep) +++import Data.List+import Data.Maybe+import Data.Either+import Data.IORef+import Debug.Trace+import Control.Monad.IO.Class+import Control.Monad ++import Foreign.Storable.Generic.Plugin.Internal.Error+import Foreign.Storable.Generic.Plugin.Internal.Compile+import Foreign.Storable.Generic.Plugin.Internal.GroupTypes+import Foreign.Storable.Generic.Plugin.Internal.Helpers+import Foreign.Storable.Generic.Plugin.Internal.Predicates+import Foreign.Storable.Generic.Plugin.Internal.Types++++--------------------+-- Grouping types --+--------------------+++groupTypes_errors :: Flags -> [Error] -> CoreM ()+groupTypes_errors flags errors = do+ let (Flags verb to_crash) = flags+ crasher errs = case errs of+ [] -> return ()+ _ -> error "Crashing..."+ print_header txt = case verb of+ None -> empty+ other -> text "Errors while grouping types - types not found for: "+ $$ nest 4 txt+ print_tyNotF verb id = case verb of+ None -> empty+ other -> ppr id $$ nest 13 (text "::") <+> ppr (varType id)+ print_err err = case err of+ TypeNotFound id -> print_tyNotF verb id+ other -> pprError verb other+ printer errs = case errs of+ [] -> return ()+ ls -> putMsg $ print_header (vcat (map print_err errs)) + -- Do printing+ -- Eventually crash.+ printer errors+ when to_crash $ crasher errors++groupTypes_info :: Flags -> [[Type]] -> CoreM ()+groupTypes_info flags types = do+ let (Flags verb _) = flags+ -- If verbosity is set, do the printing+ print_header txt = case verb of+ None -> empty+ other -> text "GStorable instances will be optimised in the following order"+ $+$ nest 4 txt+ $+$ text ""+ print_layer layer ix = int ix <> text ":" <+> fsep (punctuate comma $ map ppr layer)+ -- Print groups of types+ printer groups = case groups of+ [] -> return ()+ _ -> putMsg $ print_header (vcat $ zipWith print_layer groups [1..])+ -- Do the printing+ printer types+++-- | Find GStorable identifiers, obtain their types, and calculate+-- the order of compilation.+groupTypes :: Flags -> IORef [[Type]] -> ModGuts -> CoreM ModGuts+groupTypes flags type_order_ref guts = do+ let binds = mg_binds guts+ -- Get GStorable ids that are fully defined.+ all_ids = concatMap getIdsBind binds+ with_typecheck = withTypeCheck getGStorableType isGStorableId + predicate id = and [ with_typecheck id+ , not (hasGStorableConstraints $ varType id)+ ]+ gstorable_ids = filter predicate all_ids+ -- Now process them - different ids+ -- will have different type signatures.+ -- It is possible to fetch the types from them.+ m_gstorable_types = map (getGStorableType.varType) gstorable_ids+ -- Grab any errors related to types not found.+ bad_types_zip id m_t = case m_t of+ Nothing -> Just $ TypeNotFound id+ Just _ -> Nothing+ bad_types = catMaybes $ zipWith bad_types_zip gstorable_ids m_gstorable_types + -- type_list is used instead of type_set because Type has no uniquable instance.+ 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+ + liftIO $ writeIORef type_order_ref type_order+ return guts++++------------------------------------------------+-- Grouping and compiling GStorable CoreBinds --+------------------------------------------------++-- | Print errors related to CoreBind grouping.+-- Return the badly grouped bindings, and perhaps crash+-- the compiler.+grouping_errors :: Flags -- ^ Verbosity and ToCrash options + -> Maybe Error -- ^ The error+ -> CoreM [CoreBind] -- ^ Recovered bindings.+grouping_errors flags m_err = do+ let (Flags _ to_crash) = flags+ verb = Some+ crasher m_e = case m_e of+ Nothing -> return ()+ Just _ -> error "Crashing..."+ print_header txt = case verb of+ None -> empty+ other -> text "Errors while grouping bindings: "+ $$ nest 4 txt + printer m_err = case m_err of+ Nothing -> return ()+ Just err -> putMsg $ print_header (pprError verb err) + ungroup m_e = case m_e of+ Just (OrderingFailedBinds _ rest) -> rest+ _ -> []+ printer m_err+ when to_crash $ crasher m_err+ return $ ungroup m_err+++-- | Print the information related to found GStorable ids.+foundBinds_info :: Flags -- ^ Verbosity and ToCrash options + -> [Id] -- ^ GStorable ids.+ -> CoreM ()+foundBinds_info flags ids = do+ -- For Pretty printing+ dyn_flags <- getDynFlags+ let (Flags verb _) = flags+ -- If verbosity is set, do the printing+ print_header txt = case verb of+ None -> empty+ other -> text "The following bindings are to be optimised:"+ $+$ nest 4 txt+ print_binding id = ppr id+ max_nest = maximum $ 0 : map (length.(showSDoc dyn_flags).ppr) ids+ -- Print groups of types+ printer the_groups = case the_groups of+ [] -> return ()+ _ -> putMsg $ print_header $ vcat (map print_group the_groups)+ -- Use eqType for maybes+ eqType_maybe (Just t1) (Just t2) = t1 `eqType` t2+ eqType_maybe _ _ = False+ -- group and sort the bindings + grouped = groupBy (\i1 i2 -> (getGStorableType $ varType i1) `eqType_maybe` (getGStorableType $ varType i2) ) ids+ sorting = sortBy (\i1 i2 -> varName i1 `compare` varName i2)+ sorted = map sorting grouped+ -- print groups of bindings+ print_group the_group = case the_group of+ [] -> empty+ (h:_) -> case getGStorableType $ varType h of+ Just gtype -> ppr gtype+ $+$ (fsep $ punctuate comma (map print_binding the_group))+ Nothing -> ppr "Could not get the type of a binding:" + $+$ nest 4 (ppr h <+> text "::" <+> ppr (varType h))+ -- Print the ids+ printer sorted++-- | Do the optimisation for GStorable bindings.+gstorableSubstitution :: Flags -- ^ Verbosity and ToCrash options.+ -> IORef [[Type]] -- ^ Reference to grouped types.+ -> ModGuts -- ^ Information about compiled module.+ -> CoreM ModGuts -- ^ Information about compiled module, with GStorable optimisations.+gstorableSubstitution flags type_order_ref guts = do + type_hierarchy <- liftIO $ readIORef type_order_ref + let binds = mg_binds guts+ -- Get all GStorable binds.+ -- Check whether the type has no constraints.+ typeCheck t = if hasGStorableConstraints t+ then Nothing+ else getGStorableMethodType t+ predicate = toIsBind (withTypeCheck typeCheck isGStorableMethodId)+ + (gstorable_binds,rest) = partition predicate binds+ -- Check if there are any recursives somehow+ -- The plugin won't be able to handle them.+ (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+ -- Compile and replace gstorable bindings+ new_gstorables <- compileGroups flags grouped_binds rest -- perhaps return errors here ?+ + return $ guts {mg_binds = concat [new_gstorables, not_grouped,recs,rest]}
+ src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs view
@@ -0,0 +1,558 @@+{-|+Module : Foreign.Storable.Generic.Plugin.Internal.Compile+Copyright : (c) Mateusz Kłoczko, 2016+License : MIT+Maintainer : mateusz.p.kloczko@gmail.com+Stability : experimental+Portability : GHC-only++The core of compile and substitute optimisations.++-}+module Foreign.Storable.Generic.Plugin.Internal.Compile + ( + -- Compilation+ compileExpr+ , tryCompileExpr+ -- Int substitution+ , intToExpr+ , intSubstitution+ -- Offset substitution+ , offsetSubstitution+ , offsetSubstitutionTree+ , OffsetScope(..)+ , getScopeId+ , getScopeExpr+ , intListExpr+ , exprToIntList+ , isLitOrGlobal+ , inScopeAll+ , isIndexer+ , caseExprIndex+ -- GStorable compilation-substitution+ , compileGStorableBind+ , lintBind+ , replaceIdsBind+ , compileGroups+ )++where++-- Management of Core.+import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt, AltCon(..))+import Literal (Literal(..))+import Id (isLocalId, isGlobalId,Id)+import Var (Var(..))+import Name (getOccName,mkOccName, getSrcSpan)+import OccName (OccName(..), occNameString)+import qualified Name as N (varName, tvName, tcClsName)+import SrcLoc (noSrcSpan, SrcSpan)+import Unique (getUnique)+-- Compilation pipeline stuff+import HscMain (hscCompileCoreExpr)+import HscTypes (HscEnv,ModGuts(..))+import CoreMonad (CoreM, SimplifierMode(..),CoreToDo(..), getHscEnv, getDynFlags)+import CoreLint (lintExpr)+import BasicTypes (CompilerPhase(..))+-- Haskell types +import Type (isAlgType, splitTyConApp_maybe)+import TyCon (tyConName, algTyConRhs, visibleDataCons)+import TyCoRep (Type(..), TyBinder(..))+import TysWiredIn (intDataCon)+import DataCon (dataConWorkId,dataConOrigArgTys) ++import MkCore (mkWildValBinder)+-- Printing+import Outputable (cat, ppr, SDoc, showSDocUnsafe)+import Outputable (Outputable(..),($$), ($+$), vcat, empty,text, (<>), (<+>), nest, int, comma) +import CoreMonad (putMsg, putMsgS)++-- Used to get to compiled values+import GHCi.RemoteTypes++-- Used to create types+import TysWiredIn+import PrelNames (buildIdKey, augmentIdKey)+import DataCon (dataConWorkId)+import BasicTypes (Boxity(..))++import Unsafe.Coerce++import Data.List+import Data.Maybe+import Data.Either+import Debug.Trace+import Control.Monad.IO.Class+import Control.Monad+import Control.Applicative hiding (empty)++import Control.Exception++import Foreign.Storable.Generic.Plugin.Internal.Helpers+import Foreign.Storable.Generic.Plugin.Internal.Error+import Foreign.Storable.Generic.Plugin.Internal.Predicates+import Foreign.Storable.Generic.Plugin.Internal.Types++---------------------+-- compile helpers --+---------------------++-- | Compile an expression.+compileExpr :: HscEnv -> CoreExpr -> SrcSpan -> IO a +compileExpr hsc_env expr src_span = do+ foreign_hval <- liftIO $ hscCompileCoreExpr hsc_env src_span expr+ hval <- liftIO $ withForeignRef foreign_hval localRef+ let val = unsafeCoerce hval :: a + -- finalizeForeignRef foreign_hval -- check whether that's the source of the error+ return val++-- | Try to compile an expression. Perhaps return an error.+tryCompileExpr :: Id -> CoreExpr -> CoreM (Either Error a)+tryCompileExpr id core_expr = do+ hsc_env <- getHscEnv+ e_compiled <- liftIO $ try $ + compileExpr hsc_env core_expr (getSrcSpan id) :: CoreM (Either SomeException a)+ case e_compiled of+ Left se -> return $ Left $ CompilationError (NonRec id core_expr) (stringToPpr $ show se)+ Right val-> return $ Right val++----------------------+-- Int substitution --+----------------------++-- | Create an expression of form: \x -> 16+intToExpr :: Type -> Int -> CoreExpr+intToExpr t i = Lam wild $ App fun arg+ where fun = Var $ dataConWorkId intDataCon+ arg = Lit $ MachInt $ fromIntegral i+ wild= mkWildValBinder t ++-- | For gsizeOf and galignment - calculate the variables.+intSubstitution :: CoreBind -> CoreM (Either Error CoreBind)+intSubstitution b@(Rec _) = return $ Left $ CompilationNotSupported b+intSubstitution b@(NonRec id (Lam _ (Lam _ _))) = return $ Left $ CompilationNotSupported b +intSubstitution b@(NonRec id (Lam _ expr)) = do+ -- Get HscEnv+ hsc_env <- getHscEnv+ -- Try the subtitution.+ the_integer <- tryCompileExpr id expr :: CoreM (Either Error Int)+ -- Get the type.+ let m_t = getGStorableType (varType id) + case m_t of+ Just t -> return $ NonRec id <$> (intToExpr t <$> the_integer)+ -- If the compilation error occured, first return it.+ Nothing -> + return the_integer >> return $ Left $ CompilationError b (text "Type not found")++-----------------------+-- peek substitution --+-----------------------++-- | Try to substitute the offsets.+offsetSubstitution :: CoreBind -> CoreM (Either Error CoreBind)+offsetSubstitution b@(Rec _) = return $ Left $ CompilationNotSupported b+offsetSubstitution b@(NonRec id expr) = do+ e_subs <- offsetSubstitutionTree [] expr+ + let ne_subs = case e_subs of+ -- Add the text from other error.+ Left (OtherError sdoc) + -> Left $ CompilationError b sdoc+ -- Add the information about uncompiled expr.+ Left err@(CompilationError _ _) + -> Left $ CompilationError b (pprError Some err)+ a -> a+ + return $ NonRec id <$> e_subs+++-- | Scoped variables for optimising offsets.+data OffsetScope = IntList Id CoreExpr+ | IntPrimVal Id CoreExpr++-- | Get 'Id' from 'OffsetScope'+getScopeId :: OffsetScope -> Id+getScopeId (IntList id _) = id+getScopeId (IntPrimVal id _) = id++-- | Get 'CoreExpr' from 'OffsetScope'+getScopeExpr :: OffsetScope -> CoreExpr+getScopeExpr (IntList _ expr) = expr +getScopeExpr (IntPrimVal _ expr) = expr ++instance Outputable OffsetScope where+ ppr (IntList id expr) = ppr id <+> ppr (getUnique id) <+> comma <+> ppr expr+ ppr (IntPrimVal id expr) = ppr id <+> ppr (getUnique id) <+> comma <+> ppr expr+ pprPrec _ el = ppr el+++-- | Create a list expression from Haskell list.+intListExpr :: [Int] -> CoreExpr+intListExpr list = intListExpr' (reverse list) empty_list + where empty_list = App ( Var $ dataConWorkId nilDataCon) (Type intTy)++intListExpr' :: [Int] -> CoreExpr -> CoreExpr+intListExpr' [] acc = acc+intListExpr' (l:ls) acc = intListExpr' ls $ App int_cons acc+ where int_t_cons = App (Var $ dataConWorkId consDataCon) (Type intTy) + int_val = App (Var $ dataConWorkId intDataCon ) (Lit $ MachInt $ fromIntegral l) + int_cons = App int_t_cons int_val++-- | Compile expression to list and then write it back to core expr.+exprToIntList :: Id -> CoreExpr -> CoreM (Either Error OffsetScope)+exprToIntList id core_expr = do+ int_list <- tryCompileExpr id core_expr+ let new_expr = intListExpr <$> int_list+ return $ IntList id <$> new_expr++-- | Create a int prim expression.+intPrimValExpr :: Int -> CoreExpr+intPrimValExpr i = Lit $ MachInt $ fromIntegral i ++-- | Compile expression to int prim and then write it back to core expr.+exprToIntVal :: Id -> CoreExpr -> CoreM (Either Error OffsetScope)+exprToIntVal id core_expr = do+ int_val <- tryCompileExpr id core_expr+ let new_expr = intPrimValExpr <$> int_val+ return $ IntPrimVal id <$> new_expr++-- | Return the expression if it's a literal or global.+isLitOrGlobal :: CoreExpr -> Maybe CoreExpr+-- Whether it is a literal.+isLitOrGlobal e@(Lit _) = Just e+-- Whether it is a global id:+isLitOrGlobal e@(Var id)+ | isGlobalId id+ = Just e+isLitOrGlobal _ = Nothing++-- | Check whether the given CoreExpr is an id, +-- and if yes - substitute it.+inScopeAll :: [OffsetScope] -> CoreExpr -> Maybe CoreExpr+inScopeAll (el:rest) e@(Var v_id) + | id <- getScopeId el+ -- Thought uniques will be unique inside.+ , id == v_id+ -- Check whether the types have the same name and id.+ , getOccName (varName id) == getOccName (varName v_id)+ = Just $ getScopeExpr el+ | otherwise = inScopeAll rest e+inScopeAll _ _ = Nothing+++-- | Is an "$w!!" identifier+isIndexer :: Id + -> Bool+isIndexer id = getOccName (varName id) == mkOccName N.varName "$w!!"++-- | Try to create a compileable version of case expr body.+-- For !! @Int offsets val expressions.+caseExprIndex :: [OffsetScope] -> CoreExpr -> Maybe CoreExpr+caseExprIndex scope expr+ -- A long list of what needs to be inside the expression. + | App beg lit <- expr+ -- Substitute or leave the literal be. Otherwise cancel.+ , Just lit_expr <- inScopeAll scope lit <|> isLitOrGlobal lit+ , App beg2 offsets <- beg+ -- Substitute or leave the offsets list free.+ , Just list_expr <- inScopeAll scope offsets <|> Just offsets+ , App ix_var t_int <- beg2+ -- Get to the !! var.+ , Var ix_id <- ix_var+ -- Check whether types are ok.+ , Type intt <- t_int+ , isIntType intt+ , isIndexer ix_id+ -- New expression.+ = Just $ App (App (App ix_var t_int) list_expr) lit_expr + | otherwise = Nothing+++{- Note [Offset substitution]+ - ~~~~~~~~~~~~~~~~~~~~~~~~~~+ -+ - We would like for gpeekByteOff and gpokeByteOff methods to work as fast as + - handwritten versions. This depends on whether the field's offsets are known+ - at compile time or not. + -+ - To have offsets at compile time we have look for certain expressions to pop up.+ - We need to compile them, and later translate them back to Core expressions.+ - This approach relies on compiler optimisations of GStorable internals,+ - like inlining gpeekByteOff' methods and not inlining the calcOffsets functions. + - If these optimisations do not happen, a compilation error might occur.+ - If not, the resulting method might be not as fast as handwritten one. + -+ -+ - We expect to deal with the following expressions:+ -+ - + - 1) let offsets = ... :: [Int] in expr+ -+ - Here we compile the offsets and put them for later use in expr.+ -+ -+ - 2) case $w!! @Int offsets 0# of _ I# x -> alt_expr+ - or case $w!! @Int ... 0# of _ I# x -> alt_expr + - + - Here we substitute the offsets if we can, and then we compile the + - evaluated expression to later replace 'x' occurences in alt_expr.+ -+ -+ -}++-- | Substitute the offsets in a tree.+-- All top-level local ids should be alread in place.+-- Now try to compile selected expressions (See note [Offset substitution])+offsetSubstitutionTree :: [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)+-- Literal. Return it.+offsetSubstitutionTree scope e@(Lit _ ) = return $ Right e+-- Do substitutions for both left and right side of an application.+offsetSubstitutionTree scope e@(App e1 e2) = do+ subs1 <- offsetSubstitutionTree scope e1+ subs2 <- offsetSubstitutionTree scope e2+ return $ App <$> subs1 <*> subs2+-- Do substitution for the expressions in Cast+offsetSubstitutionTree scope e@(Cast expr c) = do+ subs <- offsetSubstitutionTree scope expr+ return $ Cast <$> subs <*> pure c+-- Do substitution for the expressions in Tick+offsetSubstitutionTree scope e@(Tick t expr) = do+ subs <- offsetSubstitutionTree scope expr+ return $ Tick t <$> subs+-- Leave types alone.+offsetSubstitutionTree scope e@(Type _ ) = return $ Right e+-- Do substitutions for the lambda body.+offsetSubstitutionTree scope e@(Lam b expr) = do+ subs <- offsetSubstitutionTree scope expr+ return $ Lam b <$> subs+-- Other substitutions: For Case, Let, and Var.+offsetSubstitutionTree scope expr+ -- Parse let offsets = ... in ... expressions.+ -- Compile offsets and put it in scope for further substitution.+ | Let offset_bind in_expr <- expr+ , NonRec offset_id offset_expr <- offset_bind+ , isOffsetsId offset_id+ = do + e_new_s <- exprToIntList offset_id offset_expr+ case e_new_s of+ Left err -> return $ Left err+ Right int_list -> offsetSubstitutionTree (int_list:scope) in_expr+ -- Normal let bindings + | Let bind in_expr <- expr+ = do + subs <- offsetSubstitutionTree scope in_expr+ -- Substitution for the bindings+ let sub_idexpr (id,e) = do+ inner_subs <- offsetSubstitutionTree scope e+ return $ (,) id <$> inner_subs+ sub_bind (NonRec id e) = do+ inner_subs <- offsetSubstitutionTree scope e+ return $ NonRec id <$> inner_subs + sub_bind (Rec bs) = do+ inner_subs <- mapM sub_idexpr bs+ case lefts inner_subs of+ [] -> return $ Right $ Rec (rights inner_subs)+ (err:_) -> return $ Left err+ bind_subs <- sub_bind bind+ --+ return $ Let <$> bind_subs <*> subs+ -- Parse case expr of _ I# x# -> ... expressions.+ -- Compile case_expr and put it in scope as x#+ -- case_expr is of format $w!! @Int offsets 0#+ | Case case_expr _ _ [alt0] <- expr+ , (DataAlt i_prim_con, [x_id], alt_expr) <- alt0+ , i_prim_con == intDataCon+ , Just new_case_expr <- caseExprIndex scope case_expr+ = do + 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 + -- Normal case expressions. + | Case case_expr cb t alts <- expr+ = do+ e_new_alts <- mapM (\(a, args, a_expr) -> (,,) a args <$> offsetSubstitutionTree scope a_expr) alts+ new_case_expr <- offsetSubstitutionTree scope case_expr+ -- Find the first error in alternative compilation+ let c_err = find (\(_,_,e) -> isLeft e) e_new_alts+ case c_err of+ Nothing -> return $ Case <$> new_case_expr + <*> pure cb <*> pure t <*> pure [(a,b,ne) | (a,b,Right ne) <- e_new_alts]+ Just (_,_,err) -> return err+ -- Variable. Return it or try to replace it.+ -- Must be here, otherwise other substitutions won't happen+ -- due to replacement of offsets to lists.+ | Var id <- expr+ = do+ let m_subs = inScopeAll scope expr+ new_e = m_subs <|> Just expr+ case new_e of+ Just e -> return $ Right e+ Nothing -> return $ Left $ OtherError (text "This shouldn't happen."+ $$ text "`m_subs <|> Just e` cannot be `Nothing`.")+ | otherwise = return $ Left $ OtherError $ (text "Unsupported expression:" $$ ppr expr)++-----------------+-- compilation --+-----------------+++-- | Compile the expression in Core Bind and replace it.+compileGStorableBind :: CoreBind -> CoreM (Either Error CoreBind) +compileGStorableBind core_bind+ -- Substitute gsizeOf+ | (NonRec id expr) <- core_bind+ , isSizeOfId id || isSpecSizeOfId id + = intSubstitution core_bind+ -- Substitute galignment+ | (NonRec id expr) <- core_bind+ , isAlignmentId id || isSpecAlignmentId id + = intSubstitution core_bind+ -- Substitute offsets in peeks.+ | (NonRec id expr) <- core_bind+ , isPeekId id || isSpecPeekId id+ = offsetSubstitution core_bind+ -- Substitute offsets in pokes.+ | (NonRec id expr) <- core_bind+ , isPokeId id || isSpecPokeId id+ = offsetSubstitution core_bind+ -- Everything else - nope.+ | otherwise = return $ Left $ CompilationNotSupported core_bind++-- | Lint a binding+lintBind :: CoreBind -- ^ Core binding to use when returning CompilationError+ -> CoreBind -- ^ Core binding to check+ -> CoreM (Either Error CoreBind) -- ^ Success or failure+lintBind b_old b@(NonRec id expr) = do+ dyn_flags <- getDynFlags+ case lintExpr dyn_flags [] expr of+ Just sdoc -> (return $ Left $ CompilationError b_old sdoc)+ Nothing -> return $ Right b+lintBind b_old b@(Rec bs) = do+ dyn_flags <- getDynFlags+ let errs = mapMaybe (\(_,expr) -> lintExpr dyn_flags [] expr) bs+ case errs of+ [] -> return $ Right b+ _ -> return $ Left $ CompilationError b_old (vcat errs)++-- | Substitutes the localIds inside the bindings with bodies of provided bindings.+replaceIdsBind :: [CoreBind] -- ^ Replace with - for GStorable bindings+ -> [CoreBind] -- ^ Replace with - for other top-bindings+ -> CoreBind -- ^ Binding which will have ids replaced.+ -> CoreBind -- ^ Binding with replaced ids.+replaceIdsBind gstorable_bs other_bs (NonRec id e) = NonRec id (replaceIds gstorable_bs other_bs e)+replaceIdsBind gstorable_bs other_bs (Rec recs) = Rec $ map (\(id,e) -> (id,replaceIds gstorable_bs other_bs e)) recs++-- | Substitutes the localIds inside the expressions with bodies of provided bindings.+replaceIds :: [CoreBind] -- ^ Replace with - for GStorable bindins+ -> [CoreBind] -- ^ Replace with - for other top-bindings+ -> CoreExpr -- ^ Expression which will have ids replaced.+ -> CoreExpr -- ^ Expression with replaced ids.+replaceIds gstorable_bs other_bs e@(Var id)+ -- For non recs.+ | isLocalId id+ , Just (_,expr) <- find ((id==).fst) $ [(id,expr) | NonRec id expr <- gstorable_bs]+ = replaceIds gstorable_bs other_bs expr+ | isLocalId id+ , Just (_,expr) <- find ((id==).fst) $ [(id,expr) | NonRec id expr <- other_bs]+ = replaceIds gstorable_bs other_bs expr+ -- For recs. The substituted component has to be removed.+ | isLocalId id+ , ([id_here],rest) <- partition (\x -> id `elem` (map fst x)) $ [bs | Rec bs <- gstorable_bs] + , Just (_,expr) <- find ((id==).fst) id_here+ = replaceIds (map Rec rest) other_bs expr+ | isLocalId id+ , ([id_here],rest) <- partition (\x -> id `elem` (map fst x)) $ [bs | Rec bs <- other_bs] + , Just (_,expr) <- find ((id==).fst) id_here+ = replaceIds gstorable_bs (map Rec rest) expr+ -- If is a global id, or id was not found (local inside the expression) - leave it alone.+ | otherwise = e+-- Replace on the left and right side of application.+replaceIds gstorable_bs other_bs (App e1 e2) = App (replaceIds gstorable_bs other_bs e1) (replaceIds gstorable_bs other_bs e2)+-- Replace the body of lambda expressions.+replaceIds gstorable_bs other_bs (Lam id e) = Lam id (replaceIds gstorable_bs other_bs e)+-- Replace both bindings and the expressions.+replaceIds gstorable_bs other_bs (Let b e) = Let (replaceIdsBind gstorable_bs other_bs b) (replaceIds gstorable_bs other_bs e)+-- Replace the case_expression and the altenatives.+replaceIds gstorable_bs other_bs (Case e ev t alts) = do+ let new_e = replaceIds gstorable_bs other_bs e+ new_alts = map (\(alt, ids, exprs) -> (alt,ids, replaceIds gstorable_bs other_bs exprs)) alts+ Case new_e ev t new_alts+-- Replace the expression in Cast+replaceIds gstorable_bs other_bs (Cast e c) = Cast (replaceIds gstorable_bs other_bs e) c+-- Replace the expression in ticks.+replaceIds gstorable_bs other_bs (Tick t e) = Tick t (replaceIds gstorable_bs other_bs e)+-- For anything else - just return it.+replaceIds gstorable_bs other_bs e = e++-- | Compile ordered binding.+compileGroups :: Flags -- ^ Error handling.+ -> [[CoreBind]] -- ^ Ordered gstorable bindings.+ -> [CoreBind] -- ^ Non-gstorable bindings, used for replacing ids.+ -> CoreM [CoreBind] -- ^ The compiled (or not) bindings.+compileGroups flags bind_groups bind_rest = compileGroups_rec flags 0 bind_groups bind_rest [] []+++-- | The insides of compileGroups method.+compileGroups_rec :: Flags -- ^ For error handling.+ -> Int -- ^ Depth, useful for debugging.+ -> [[CoreBind]] -- ^ Ordered GStorable bindings. + -> [CoreBind] -- ^ Other top-level bindings+ -> [CoreBind] -- ^ Succesfull substitutions.+ -> [CoreBind] -- ^ Unsuccesfull substitutions.+ -> CoreM [CoreBind] -- ^ Both successfull and unsuccesfull subtitutions.+compileGroups_rec flags _ [] bind_rest subs not_subs = return $ concat [subs,not_subs]+compileGroups_rec flags d (bg:bgs) bind_rest subs not_subs = do+ let layer_replaced = map (replaceIdsBind bind_rest subs) bg+ -- Compile and then lint.+ compile_and_lint bind = do+ e_compiled <- compileGStorableBind bind+ -- Monad transformers would be nice here.+ case e_compiled of+ Right bind' -> lintBind bind bind'+ _ -> return e_compiled + -- Compiled (or not) expressions+ e_compiled <- mapM compile_and_lint layer_replaced+ let errors = lefts e_compiled+ compiled = rights e_compiled + + -- Handle errors + not_compiled <- compileGroups_error flags d errors+ -- Next iteration.+ compileGroups_rec flags (d+1) bgs bind_rest (concat [compiled,subs]) (concat [not_compiled, not_subs])++-- | Handle errors during the compileGroups stage.+compileGroups_error :: Flags -- ^ Error handling+ -> Int -- ^ Current iteration+ -> [Error] -- ^ List of errors+ -> CoreM [CoreBind] -- ^ Bindings from errors.+compileGroups_error flags d errors = do+ let (Flags verb to_crash) = flags+ -- To crash handler+ crasher errs = case errs of+ [] -> return ()+ _ -> error "Crashing..."+ -- Print header for this type of errors+ print_header txt = case verb of+ None -> empty+ other -> text "Errors while compiling and substituting bindings at depth " <+> int d <> text ":" + $$ nest 4 txt + -- Print errors themselves+ printer errs = case errs of+ [] -> return ()+ -- Print with header+ ls -> putMsg $ print_header (vcat (map (pprError verb) errs)) + -- Get the bindings from errors.+ ungroup err = case err of+ (CompilationNotSupported bind) -> Just bind+ (CompilationError bind _) -> Just bind+ -- If we get Nothing, we will probably get missing symbols.+ -- TODO: Handle such situations.+ _ -> Nothing++ -- Print errors+ printer errors+ -- Crash if conditions are met+ when to_crash $ crasher errors+ -- Return bindings+ return $ mapMaybe ungroup errors
+ src/Foreign/Storable/Generic/Plugin/Internal/Error.hs view
@@ -0,0 +1,159 @@+{-|+Module : Foreign.Storable.Generic.Plugin.Internal.Error+Copyright : (c) Mateusz Kłoczko, 2016+License : MIT+Maintainer : mateusz.p.kloczko@gmail.com+Stability : experimental+Portability : GHC-only++Contains the Error datatype and related pretty print functions. ++-}+module Foreign.Storable.Generic.Plugin.Internal.Error + ( Verbosity(..)+ , CrashOnWarning(..)+ , Flags(..)+ , Error(..)+ , pprError+ , stringToPpr+ ) where++import Id (Id)+import Var(Var(..))+import CoreSyn (CoreBind(..), Bind(..),CoreExpr(..))+import Type (Type)+import Outputable++import Foreign.Storable.Generic.Plugin.Internal.Helpers++-- | How verbose should the messages be.+data Verbosity = None | Some | All ++-- | Crash when an recoverable error occurs. For testing purposes.+type CrashOnWarning = Bool++-- | Contains user-specified flags.+data Flags = Flags Verbosity CrashOnWarning++-- | All possible errors.+data Error = TypeNotFound Id -- ^ Could not obtain the type from the id.+ | RecBinding CoreBind -- ^ The binding is recursive and won't be substituted.+ | CompilationNotSupported CoreBind -- ^ The compilation-substitution is not supported for the given binding.+ | CompilationError CoreBind SDoc -- ^ Error during compilation. The CoreBind is to be returned.+ | OrderingFailedBinds Int [CoreBind] -- ^ Ordering failed for core bindings.+ | OrderingFailedTypes Int [Type] -- ^ Ordering failed for types+ | OtherError SDoc -- ^ Any other error.++pprTypeNotFound :: Verbosity -> Id -> SDoc+pprTypeNotFound None _ = empty +pprTypeNotFound Some id + = text "Could not obtain the type from" + $$ nest 4 (ppr id <+> text "::" <+> ppr (varType id) ) +pprTypeNotFound All id = pprTypeNotFound Some id++pprRecBinding :: Verbosity -> CoreBind -> SDoc+pprRecBinding None _ = empty+pprRecBinding Some (Rec bs) + = text "The binding is recursive and won't be substituted"+ $$ nest 4 (vcat ppr_ids)+ where ppr_ids = map (\(id,_) -> ppr id <+> text "::" <+> ppr (varType id) ) bs+pprRecBinding Some (NonRec id _) + = text "RecBinding error for non recursive binding...?"+ $$ nest 4 (ppr id <+> text "::" <+> ppr (varType id) ) +pprRecBinding All b@(Rec _) + = text "--- The binding is recursive and won't be substituted ---"+ $+$ text ""+ $+$ nest 4 (ppr b)+ $+$ text ""+pprRecBinding All b@(NonRec _ _) + = text "--- RecBinding error for non recursive binding ? ---"+ $+$ text ""+ $+$ nest 4 (ppr b)+ $+$ text ""++pprCompilationNotSupported :: Verbosity -> CoreBind -> SDoc+pprCompilationNotSupported None _ = empty+pprCompilationNotSupported Some bind + = text "Compilation is not supported for bindings of the following format: "+ $$ nest 4 (vcat ppr_ids)+ where ppr_ids = map (\id -> ppr id <+> text "::" <+> ppr (varType id) ) $ getIdsBind bind+pprCompilationNotSupported All bind + = text "--- Compilation is not supported for bindings of the following format ---"+ $+$ text ""+ $+$ nest 4 (ppr bind) + $+$ text ""++++pprCompilationError :: Verbosity -> CoreBind -> SDoc -> SDoc+pprCompilationError None _ _ = empty+pprCompilationError Some bind sdoc+ = text "Compilation failed for the following binding: "+ $$ nest 4 (vcat ppr_ids)+ $$ nest 4 (text "The error was:" $$ nest 5 sdoc)+ where ppr_ids = map (\id -> ppr id <+> text "::" <+> ppr (varType id) ) $ getIdsBind bind+pprCompilationError All bind sdoc+ = text "--- Compilation failed for the following binding ---"+ $+$ text ""+ $+$ nest 4 (text "Error message: ")+ $+$ nest 4 sdoc+ $+$ text ""+ $+$ nest 4 (ppr bind) + $+$ text ""++pprOrderingFailedTypes :: Verbosity -> Int -> [Type] -> SDoc+pprOrderingFailedTypes None _ _ = empty+pprOrderingFailedTypes Some depth types + = text "Type ordering failed at depth" <+> int depth <+> text "for types:"+ $$ nest 4 (vcat ppr_types)+ where ppr_types = map ppr types+pprOrderingFailedTypes All depth types = pprOrderingFailedTypes Some depth types++pprOrderingFailedBinds :: Verbosity -> Int -> [CoreBind] -> SDoc+pprOrderingFailedBinds None _ _ = empty+pprOrderingFailedBinds Some depth binds + = text "CoreBind ordering failed at depth" <+> int depth <+> text "for bindings:"+ $$ nest 4 (vcat ppr_ids)+ where ppr_ids = map (\id -> ppr id <+> text "::" <+> ppr (varType id) ) $ concatMap getIdsBind binds+pprOrderingFailedBinds All depth binds+ = text "--- CoreBind ordering failed at depth" <+> int depth <+> text "for bindings ---"+ $+$ text "\n"+ $+$ nest 4 (vcat ppr_binds)+ $+$ text ""+ where ppr_binds = map ppr binds++pprOtherError :: Verbosity -> SDoc -> SDoc+pprOtherError None _ = empty+pprOtherError _ sdoc = sdoc++-- | Print an error according to verbosity flag.+pprError :: Verbosity -> Error -> SDoc+pprError verb (TypeNotFound id ) = pprTypeNotFound verb id+pprError verb (RecBinding bind) = pprRecBinding verb bind+pprError verb (CompilationNotSupported bind) = pprCompilationNotSupported verb bind+pprError verb (CompilationError bind str) = pprCompilationError verb bind str+pprError verb (OrderingFailedBinds d bs) = pprOrderingFailedBinds verb d bs+pprError verb (OrderingFailedTypes d ts) = pprOrderingFailedTypes verb d ts+pprError verb (OtherError sdoc ) = pprOtherError verb sdoc+++-- | Change String to SDoc.+-- Each newline is $$ed with nest equal to spaces before.+-- \t is 4.+stringToPpr :: String -> SDoc+stringToPpr str = do+ -- Whether to take a letter+ let taker ' ' = True+ taker '\t' = True+ taker _ = False+ -- Whether to + to_num ' ' = 1+ to_num '\t' = 4+ to_num _ = 0+ -- Function doing the nesting+ let nest_text str = do+ let whites = takeWhile taker str+ rest = dropWhile taker str+ num = sum $ map to_num whites+ nest num $ text rest+ vcat $ map nest_text $ lines str
+ src/Foreign/Storable/Generic/Plugin/Internal/GroupTypes.hs view
@@ -0,0 +1,165 @@+{-|+Module : Foreign.Storable.Generic.Plugin.Internal.GroupTypes+Copyright : (c) Mateusz Kłoczko, 2016+License : MIT+Maintainer : mateusz.p.kloczko@gmail.com+Stability : experimental+Portability : GHC-only++Grouping methods, both for types and core bindings.+-}+module Foreign.Storable.Generic.Plugin.Internal.GroupTypes + (+ -- Type ordering+ calcGroupOrder+ , substituteTyCon+ , getDataConArgs+ -- CoreBind ordering+ , groupBinds+ )+where++-- Management of Core.+import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt)+import Literal (Literal(..))+import Id (isLocalId, isGlobalId,Id)+import Var (Var(..))+import Name (getOccName,mkOccName)+import OccName (OccName(..), occNameString)+import qualified Name as N (varName)+import SrcLoc (noSrcSpan)+import Unique (getUnique)+-- Compilation pipeline stuff+import HscMain (hscCompileCoreExpr)+import HscTypes (HscEnv,ModGuts(..))+import CoreMonad (CoreM, SimplifierMode(..),CoreToDo(..), getHscEnv)+import BasicTypes (CompilerPhase(..))+-- Haskell types +import Type (isAlgType, splitTyConApp_maybe)+import TyCon (algTyConRhs, visibleDataCons)+import TyCoRep (Type(..), TyBinder(..))+import TysWiredIn (intDataCon)+import DataCon (dataConWorkId,dataConOrigArgTys) ++import MkCore (mkWildValBinder)+-- Printing+import Outputable (cat, ppr, SDoc, showSDocUnsafe)+import Outputable (text, (<+>), ($$), nest)+import CoreMonad (putMsg, putMsgS)++-- Used to get to compiled values+import GHCi.RemoteTypes++import TyCon+import Type hiding (eqType)++import Unsafe.Coerce++import Data.List+import Data.Maybe+import Data.Either+import Debug.Trace+import Control.Monad.IO.Class++import Foreign.Storable.Generic.Plugin.Internal.Error+import Foreign.Storable.Generic.Plugin.Internal.Helpers+import Foreign.Storable.Generic.Plugin.Internal.Predicates+import Foreign.Storable.Generic.Plugin.Internal.Types+++-- | Calculate the order of types. +calcGroupOrder :: [Type] -> ([[Type]], Maybe Error)+calcGroupOrder types = calcGroupOrder_rec types []++calcGroupOrder_rec :: [Type]+ -> [[Type]]+ -> ([[Type]], Maybe Error)+calcGroupOrder_rec [] acc = (reverse acc, Nothing)+calcGroupOrder_rec types acc = do+ let (layer, rest) = calcGroupOrder_iteration types [] [] []+ layer' = nubBy eqType layer+ if length layer' == 0+ then (reverse acc, Just $ OrderingFailedTypes (length acc) rest)+ else calcGroupOrder_rec rest (layer':acc)++-- | This could be done more efficently if we'd +-- represent the problem as a graph problem.+calcGroupOrder_iteration :: [Type] -- ^ Type to check + -> [Type] -- ^ Type that are checked+ -> [Type] -- ^ Type that are in this layer+ -> [Type] -- ^ Type that are not.+ -> ([Type], [Type]) -- Returning types in this layer and the next ones.+calcGroupOrder_iteration [] checked accepted rejected = (accepted, rejected)+calcGroupOrder_iteration (t:ts) checked accepted rejected = do+ let args = getDataConArgs t+ -- Are the t's arguments equal to some other ?+ is_arg_somewhere = any (\t -> elemType t args) checked || any (\t -> elemType t args) ts++ if is_arg_somewhere+ then calcGroupOrder_iteration ts (t:checked) accepted (t:rejected)+ else calcGroupOrder_iteration ts (t:checked) (t:accepted) rejected++-- | Used for type substitution. +-- Whether a TyVar appears, replace it with a Type.+type TypeScope = (TyVar, Type)++-- | Functions doing the type substitutions.++-- Examples+-- +-- substituteTyCon [(a,Int)] a = Int+-- substituteTyCon [(a,Int),(b,Char)] (AType b a) = AType Char Int+substituteTyCon :: [TypeScope] -> Type -> Type+substituteTyCon [] tc_app = tc_app+substituteTyCon type_scope old@(TyVarTy ty_var) +-- Substitute simple type variables+ = case find (\(av,_) -> av == ty_var) type_scope of+ Just (_, new_type) -> new_type+ Nothing -> old+substituteTyCon type_scope (TyConApp tc args)+-- Substitute type constructors+ = TyConApp tc $ map (substituteTyCon type_scope) args+substituteTyCon type_scope t = t ++-- | Get data constructor arguments from an algebraic type.+getDataConArgs :: Type -> [Type]+getDataConArgs t + | isAlgType t+ , Just (tc, ty_args) <- splitTyConApp_maybe t+ , ty_vars <- tyConTyVars tc+ = do+ -- Substitute data_cons args with type args,+ -- using ty_vars as keys.+ let type_scope = zip ty_vars ty_args+ data_cons = concatMap dataConOrigArgTys $ (visibleDataCons.algTyConRhs) tc+ map (substituteTyCon type_scope) data_cons + | otherwise = []++++-- | Group bindings according to type groups.+groupBinds :: [[Type]] -- ^ Type groups.+ -> [CoreBind] -- ^ Should be only NonRecs. + -> ([[CoreBind]], Maybe Error)+-- perhaps add some safety so non-recs won't get here.+groupBinds type_groups binds = groupBinds_rec type_groups binds [] ++-- | Iteration for groupBinds+groupBinds_rec :: [[Type]] -- ^ Group of types+ -> [CoreBind] -- ^ Ungrouped bindings+ -> [[CoreBind]] -- ^ Grouped bindings+ -> ([[CoreBind]], Maybe Error) -- ^ Grouped bindings, and perhaps an error)+groupBinds_rec [] [] acc = (reverse acc,Nothing)+groupBinds_rec (a:as) [] acc = (reverse acc,Just $ OtherError msg)+ where msg = text "Could not find any bindings." + $$ text "Is the second pass placed after main simplifier phases ?" +groupBinds_rec [] binds acc = (reverse acc,Just $ OrderingFailedBinds (length acc) binds)+groupBinds_rec (tg:tgs) binds acc = do+ let predicate (NonRec id _) = case getGStorableType $ varType id of+ Just t -> t `elemType` tg+ Nothing -> False+ predicate (Rec _) = False+ let (layer, rest) = partition predicate binds+ if length layer == 0 + then (reverse acc, Just $ OrderingFailedBinds (length acc) rest)+ else groupBinds_rec tgs rest (reverse layer:acc)
+ src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs view
@@ -0,0 +1,113 @@+{-|+Module : Foreign.Storable.Generic.Plugin.Internal.Helpers+Copyright : (c) Mateusz Kłoczko, 2016+License : MIT+Maintainer : mateusz.p.kloczko@gmail.com+Stability : experimental+Portability : GHC-only++Various helping functions.++-}+module Foreign.Storable.Generic.Plugin.Internal.Helpers where++-- Management of Core.+import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt)+import Literal (Literal(..))+import Id (isLocalId, isGlobalId,Id)+import Var (Var(..))+import Name (getOccName,mkOccName)+import OccName (OccName(..), occNameString)+import qualified Name as N (varName)+import SrcLoc (noSrcSpan)+import Unique (getUnique)+-- Compilation pipeline stuff+import HscMain (hscCompileCoreExpr)+import HscTypes (HscEnv,ModGuts(..))+import CoreMonad (CoreM, SimplifierMode(..),CoreToDo(..), getHscEnv)+import BasicTypes (CompilerPhase(..))+-- Haskell types +import Type (isAlgType, splitTyConApp_maybe)+import TyCon (algTyConRhs, visibleDataCons)+import TyCoRep (Type(..), TyBinder(..))+import TysWiredIn (intDataCon)+import DataCon (dataConWorkId,dataConOrigArgTys) ++import MkCore (mkWildValBinder)+-- Printing+import Outputable (cat, ppr, SDoc, showSDocUnsafe)+import CoreMonad (putMsg, putMsgS)++-- Used to get to compiled values+import GHCi.RemoteTypes++++import Unsafe.Coerce++import Data.List+import Data.Maybe+import Data.Either+import Debug.Trace+import Control.Monad.IO.Class+++-- | Get ids from core bind.+getIdsBind :: CoreBind -> [Id]+getIdsBind (NonRec id _) = [id]+getIdsBind (Rec recs) = map fst recs++-- | Get all expressions from a binding.+getExprsBind :: CoreBind -> [CoreExpr]+getExprsBind (NonRec _ e) = [e]+getExprsBind (Rec recs) = map snd recs++-- | Get both identifiers and expressions from a binding.+getIdsExprsBind :: CoreBind -> [(Id,CoreExpr)]+getIdsExprsBind (NonRec id expr) = [(id,expr)]+getIdsExprsBind (Rec recs) = recs++-- | Get all IDs from CoreExpr+getIdsExpr :: CoreExpr -> [Id]+getIdsExpr (Var id) = [id]+getIdsExpr (App e1 e2) = concat [getIdsExpr e1, getIdsExpr e2]+getIdsExpr (Lam id e) = id : getIdsExpr e+-- Ids from bs are ignored, as they are supposed to appear in e argument.+getIdsExpr (Let bs e) = concat [getIdsExpr e, concatMap getIdsExpr (getExprsBind bs)]+-- The case_binder is ignored - the evaluated expression might appear on the rhs of alts+getIdsExpr (Case e _ _ alts) = concat $ getIdsExpr e : map (\(_,_,e_c) -> getIdsExpr e_c) alts+getIdsExpr (Cast e _) = getIdsExpr e +getIdsExpr _ = []+++------------+-- others --+------------+++-- | Takes first n characters out of occName+cutOccName :: Int -> OccName -> OccName+cutOccName n occ_name = mkOccName (occNameSpace occ_name) name_string+ where name_string = take n $ occNameString occ_name+++-- HACK for type equality+-- | Equality for types+eqType :: Type -> Type -> Bool+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)+eqType (ForAllTy tb1 t1) (ForAllTy tb2 t2) = tb1 `eqTyBind` tb2 && t1 `eqType` t2+-- Not dealing with type coercions or casts.+eqType _ _ = False++-- | Equality for type binders+eqTyBind :: TyBinder -> TyBinder -> Bool+eqTyBind (Named t1 vis1) (Named t2 vis2) = t1 == t2 && vis1 == vis2+eqTyBind (Anon t1) (Anon t2) = t1 `eqType` t2+eqTyBind _ _ = False++-- | 'elem' function for types+elemType :: Type -> [Type] -> Bool+elemType t [] = False+elemType t (ot:ts) = (t `eqType` ot) || elemType t ts
+ src/Foreign/Storable/Generic/Plugin/Internal/Predicates.hs view
@@ -0,0 +1,175 @@+{-|+Module : Foreign.Storable.Generic.Plugin.Internal.Predicates+Copyright : (c) Mateusz Kłoczko, 2016+License : MIT+Maintainer : mateusz.p.kloczko@gmail.com+Stability : experimental+Portability : GHC-only++Predicates for finding GStorable identifiers, plus some others.++-}+module Foreign.Storable.Generic.Plugin.Internal.Predicates + (+ -- Predicates on identifiers+ isGStorableInstId+ , isSizeOfId+ , isAlignmentId+ , isPeekId+ , isPokeId+ , isSpecGStorableInstId+ , isSpecSizeOfId+ , isSpecAlignmentId+ , isSpecPeekId+ , isSpecPokeId+ , isOffsetsId+ -- Groups of above+ , isGStorableId+ , isGStorableMethodId+ -- Miscellanous+ , isNonRecBind+ , toIsBind+ , withTypeCheck+ )+where++-- Management of Core.+import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt)+import Literal (Literal(..))+import Id (isLocalId, isGlobalId,Id)+import Var (Var(..))+import Name (getOccName,mkOccName)+import OccName (OccName(..), occNameString)+import qualified Name as N (varName, tcClsName)+import SrcLoc (noSrcSpan)+import Unique (getUnique)+-- Compilation pipeline stuff+import HscMain (hscCompileCoreExpr)+import HscTypes (HscEnv,ModGuts(..))+import CoreMonad (CoreM, SimplifierMode(..),CoreToDo(..), getHscEnv)+import BasicTypes (CompilerPhase(..))+-- Types +import Type (isAlgType, splitTyConApp_maybe)+import TyCon (TyCon,tyConName, algTyConRhs, visibleDataCons)+import TyCoRep (Type(..), TyBinder(..))+import TysWiredIn (intDataCon)+import DataCon (dataConWorkId,dataConOrigArgTys) ++import MkCore (mkWildValBinder)+-- Printing+import Outputable (cat, ppr, SDoc, showSDocUnsafe)+import CoreMonad (putMsg, putMsgS)++++import Data.Maybe ++import Foreign.Storable.Generic.Plugin.Internal.Helpers+++++-- | Predicate used to find GStorable instances identifiers.+isGStorableInstId :: Id -> Bool+isGStorableInstId id = cutted_occ_name == gstorable_dict_name + && cutted_occ_name2 /= gstorable'_dict_name+ where cutted_occ_name = cutOccName 11 $ getOccName (varName id)+ cutted_occ_name2 = cutOccName 12 $ getOccName (varName id)+ gstorable_dict_name = mkOccName N.varName "$fGStorable"+ gstorable'_dict_name = mkOccName N.varName "$fGStorable'"++-- | Predicate used to find gsizeOf identifiers+isSizeOfId :: Id -> Bool+isSizeOfId ident = getOccName (varName ident) == mkOccName N.varName "$cgsizeOf" ++-- | Predicate used to find galignment identifiers+isAlignmentId :: Id -> Bool+isAlignmentId ident = getOccName (varName ident) == mkOccName N.varName "$cgalignment" ++-- | Predicate used to find gpeekByteOff identifiers+isPeekId :: Id -> Bool+isPeekId ident = getOccName (varName ident) == mkOccName N.varName "$cgpeekByteOff" ++-- | Predicate used to find gpeekByteOff identifiers+isPokeId :: Id -> Bool+isPokeId ident = getOccName (varName ident) == mkOccName N.varName "$cgpokeByteOff" +++--------------------------------------------+--Specialized at instance definition site.--+--------------------------------------------++-- | Predicate used to find specialized GStorable instance identifiers+isSpecGStorableInstId :: Id -> Bool+isSpecGStorableInstId id = cutted_occ_name == gstorable_dict_name+ && cutted_occ_name2 /= gstorable'_dict_name+ where cutted_occ_name = cutOccName 11 $ getOccName (varName id)+ cutted_occ_name2 = cutOccName 12 $ getOccName (varName id)+ gstorable_dict_name = mkOccName N.varName "$s$fGStorable"+ gstorable'_dict_name = mkOccName N.varName "$s$fGStorable'"++-- | Predicate used to find specialized gsizeOf identifiers+isSpecSizeOfId :: Id -> Bool+isSpecSizeOfId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgsizeOf" ++-- | Predicate used to find specialized galignment identifiers+isSpecAlignmentId :: Id -> Bool+isSpecAlignmentId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgalignment" ++-- | Predicate used to find specialized gpeekByteOff identifiers+isSpecPeekId :: Id -> Bool+isSpecPeekId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgpeekByteOff" ++-- | Predicate used to find specialized gpokeByteOff identifiers+isSpecPokeId :: Id -> Bool+isSpecPokeId ident = getOccName (varName ident) == mkOccName N.varName "$s$cgpokeByteOff" +++----------------------------+-- For offset calculation --+----------------------------++-- | Is offsets id.+isOffsetsId :: Id -> Bool+isOffsetsId id = getOccName (varName id) == mkOccName N.varName "offsets"++---------------------------+-- Groups of identifiers --+---------------------------++-- | Is a GStorable identifier+isGStorableId :: Id -> Bool+isGStorableId id = any ($id) [ isSizeOfId, isAlignmentId, isPeekId+ , isPokeId, isGStorableInstId+ , isSpecSizeOfId, isSpecAlignmentId+ , isSpecPeekId, isSpecPokeId+ , isSpecGStorableInstId+ ]+-- | Is the id an GStorable method.+isGStorableMethodId :: Id -> Bool +isGStorableMethodId id = any ($id) [isSizeOfId, isAlignmentId+ , isPeekId, isPokeId+ , isSpecSizeOfId, isSpecAlignmentId+ , isSpecPeekId, isSpecPokeId+ ]+------------------ +-- Miscellanous --+------------------++-- | Check if binding is non-recursive.+isNonRecBind :: CoreBind -> Bool+isNonRecBind (NonRec _ _) = True+isNonRecBind _ = False++-- | Lift the identifier predicate to work on a core binding.+toIsBind :: (Id -> Bool) -> CoreBind -> Bool+toIsBind pred (NonRec id rhs) = pred id+toIsBind pred (Rec bs) = any pred $ map fst bs++-- | Use both type getters and identifier predicate to create a predicate.+withTypeCheck :: (Type -> Maybe Type) -> (Id -> Bool) -> Id -> Bool+withTypeCheck ty_f id_f id = do+ let ty_checked = ty_f $ varType id+ id_checked = id_f id+ and [isJust ty_checked, id_checked]+
+ src/Foreign/Storable/Generic/Plugin/Internal/Types.hs view
@@ -0,0 +1,279 @@+{-|+Module : Foreign.Storable.Generic.Plugin.Internal.Types+Copyright : (c) Mateusz Kłoczko, 2016+License : MIT+Maintainer : mateusz.p.kloczko@gmail.com+Stability : experimental+Portability : GHC-only++Functions for obtaining types from GStorable methods and instances.++-}+module Foreign.Storable.Generic.Plugin.Internal.Types+ (+ -- Type predicates+ isIntType+ , isPtrType+ , isIOType+ , isIOTyCon+ , isStatePrimType+ , isStatePrimTyCon+ , isRealWorldType+ , isRealWorldTyCon+ , isGStorableInstTyCon+ , hasConstraintKind+ , hasGStorableConstraints+ -- Used to obtain types+ , getGStorableInstType+ , getAlignmentType+ , getSizeType+ , getPeekType+ , getPokeType+ , getOffsetsType+ -- Combinations of above+ , getGStorableType+ , getGStorableMethodType+ )+ where++-- Management of Core.+import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt)+import Literal (Literal(..))+import Id (isLocalId, isGlobalId,Id)+import Var (Var(..))+import Name (getOccName,mkOccName)+import OccName (OccName(..), occNameString)+import qualified Name as N (varName,tcClsName)+import SrcLoc (noSrcSpan)+import Unique (getUnique)+-- Compilation pipeline stuff+import HscMain (hscCompileCoreExpr)+import HscTypes (HscEnv,ModGuts(..))+import CoreMonad (CoreM, SimplifierMode(..),CoreToDo(..), getHscEnv)+import BasicTypes (CompilerPhase(..))+-- Haskell types +import Type (isAlgType, splitTyConApp_maybe)+import TyCon (TyCon(..),algTyConRhs, visibleDataCons)+import TyCoRep (Type(..), TyBinder(..))+import TysWiredIn (intDataCon)+import DataCon (dataConWorkId,dataConOrigArgTys) ++import MkCore (mkWildValBinder)+-- Printing+import Outputable (cat, ppr, SDoc, showSDocUnsafe)+import CoreMonad (putMsg, putMsgS)++-- Used to get to compiled values+import GHCi.RemoteTypes++++import Unsafe.Coerce++import Data.List+import Data.Maybe+import Data.Either+import Debug.Trace+import Control.Applicative+import Control.Monad.IO.Class+++import Foreign.Storable.Generic.Plugin.Internal.Helpers+++-- Function for getting types from an id.+import TyCon (isUnboxedTupleTyCon)+import TysWiredIn (intTyCon, constraintKind, constraintKindTyCon, listTyCon, intTy)+import PrelNames (ioTyConKey, ptrTyConKey, realWorldTyConKey, statePrimTyConKey)+import Type (isUnboxedTupleType)+++-- | Check whether the type is integer+isIntType :: Type -> Bool+isIntType (TyConApp int []) = int == intTyCon+isIntType _ = False++-- | Check whether the type is a Pointer+isPtrType :: Type -> Bool+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+isIOType _ = False++-- | Check whether the type constructor is an IO.+isIOTyCon :: TyCon -> Bool+isIOTyCon io = getUnique io == ioTyConKey++-- | Check whether the type is a State#+isStatePrimType :: Type -> Bool+isStatePrimType (TyConApp st [el]) = isStatePrimTyCon st+isStatePrimType _ = False++-- | Check whether the type constructor is a State#+isStatePrimTyCon :: TyCon -> Bool+isStatePrimTyCon st = getUnique st == statePrimTyConKey++-- | Check whether the type is a RealWorld#+isRealWorldType :: Type -> Bool+isRealWorldType (TyConApp rw []) = isRealWorldTyCon rw+isRealWorldType _ = False++-- | Check whether the type constructor is a RealWorld#+isRealWorldTyCon :: TyCon -> Bool+isRealWorldTyCon rw = getUnique rw == realWorldTyConKey++-- | Check whether the type constuctor is a GStorable+isGStorableInstTyCon :: TyCon -> Bool+isGStorableInstTyCon tc = getOccName (tyConName tc) == mkOccName N.tcClsName "GStorable" ++-- | Check whether the type is of kind * -> Constraint.+hasConstraintKind :: Type -> Bool+hasConstraintKind ty + | TyConApp tc [a] <- ty+ , ForAllTy star kind_ty <- tyConKind tc+ , TyConApp k_tc [] <- kind_ty+ = constraintKindTyCon == k_tc+ | otherwise = False++-- | Check whether the type has GStorable constraints.+hasGStorableConstraints :: Type -> Bool+hasGStorableConstraints t+ | ForAllTy bind next <- t+ , Anon gstorable_cons <- bind+ , hasConstraintKind gstorable_cons+ , TyConApp gstorable_tc [_] <- gstorable_cons+ , isGStorableInstTyCon gstorable_tc+ = True+ | ForAllTy _ next <- t+ = hasGStorableConstraints next+ | otherwise = False+++-- | Get the type from GStorable instance.+getGStorableInstType :: Type -> Maybe Type+getGStorableInstType t+ | hasConstraintKind t+ , TyConApp gstorable [the_t] <- t + = Just the_t+ -- Ignore forall a. a, GStorable a =>, etc..+ | ForAllTy _ some_t <- t = getGStorableInstType some_t+ | otherwise = Nothing+++-- | Get the type from GStorable alignment method+getAlignmentType :: Type -> Maybe Type+getAlignmentType t+ -- Assuming there are no anonymous ty bind between+ -- the type and the integer, ie no : Type -> forall a. Int+ | ForAllTy ty_bind int_t <- t+ , isIntType int_t + , Anon the_t <- ty_bind+ = Just the_t+ | ForAllTy _ some_t <- t = getAlignmentType some_t+ | otherwise = Nothing++-- | Get the type from GStorable sizeOf method+getSizeType :: Type -> Maybe Type+getSizeType t+ -- Assuming there are no anonymous ty bind between+ -- the type and the integer, ie no : Type -> forall a. Int+ | ForAllTy ty_bind int_t <- t+ , isIntType int_t + , Anon the_t <- ty_bind+ = 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 + -> Bool -- ^ Is after Ptr+ -> Bool -- ^ Is after Int+ -> Maybe Type -- ^ Returning+getPeekType' t after_ptr after_int + -- Last step: IO (TheType)+ | after_ptr, after_int+ , TyConApp io_tc [the_t] <- t+ , isIOTyCon io_tc+ = Just the_t+ -- Int -> IO (TheType)+ | after_ptr+ , ForAllTy ty_bind io_t <- t+ , Anon int_t <- ty_bind+ , isIntType int_t+ = getPeekType' io_t True True+ -- Ptr b -> Int -> IO (TheType)+ | ForAllTy ty_bind int_t <- t+ , Anon ptr_t <- ty_bind+ , isPtrType ptr_t+ = getPeekType' int_t True False+ -- Ignore other types+ -- including constraints and + -- Named ty binders.+ | ForAllTy _ some_t <- t+ = getPeekType' some_t after_ptr after_int+ | otherwise = Nothing+++-- | 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+ -> Maybe Type -- ^ Returning+getPokeType' t after_ptr after_int + -- Last step: TheType -> IO ()+ | after_ptr, after_int+ , ForAllTy ty_bind io_t <- t+ , isIOType io_t+ , Anon the_t <- ty_bind+ = Just the_t+ -- Int -> TheType -> IO ()+ | after_ptr+ , ForAllTy ty_bind rest <- t+ , Anon int_t <- ty_bind+ , isIntType int_t+ = getPokeType' rest True True+ -- Ptr b -> Int -> TheType -> IO ()+ | ForAllTy ty_bind int_rest <- t+ , Anon ptr_t <- ty_bind+ , isPtrType ptr_t+ = getPokeType' int_rest True False+ -- Ignore other types+ -- including constraints and + -- Named ty binders.+ | ForAllTy _ some_t <- t+ = getPokeType' some_t after_ptr after_int+ | otherwise = Nothing+++-- | Get the type of Offsets. Assuming it is [Int]+getOffsetsType :: Type -> Maybe Type+getOffsetsType ty+ | TyConApp list_tc [int_t] <- ty+ , listTyCon == list_tc+ , intTy `eqType` int_t+ = Just ty+ | otherwise = Nothing++-- | Combination of type getters for all GStorables.+getGStorableType :: Type -> Maybe Type+getGStorableType t = getGStorableInstType t <|> getSizeType t <|> getAlignmentType t <|> getPokeType t <|> getPeekType t++-- | Combination of type getters for GStorable methods.+getGStorableMethodType :: Type -> Maybe Type+getGStorableMethodType t = getSizeType t <|> getAlignmentType t <|> getPokeType t <|> getPeekType t