diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for generic-storable-plugin + +## 0.1.0.0 -- 2016-09-08 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/derive-storable-plugin.cabal b/derive-storable-plugin.cabal new file mode 100644 --- /dev/null +++ b/derive-storable-plugin.cabal @@ -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 diff --git a/src/Foreign/Storable/Generic/Plugin.hs b/src/Foreign/Storable/Generic/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Storable/Generic/Plugin.hs @@ -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 diff --git a/src/Foreign/Storable/Generic/Plugin/Internal.hs b/src/Foreign/Storable/Generic/Plugin/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Storable/Generic/Plugin/Internal.hs @@ -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]} diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs b/src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Storable/Generic/Plugin/Internal/Compile.hs @@ -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 diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/Error.hs b/src/Foreign/Storable/Generic/Plugin/Internal/Error.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Storable/Generic/Plugin/Internal/Error.hs @@ -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 diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/GroupTypes.hs b/src/Foreign/Storable/Generic/Plugin/Internal/GroupTypes.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Storable/Generic/Plugin/Internal/GroupTypes.hs @@ -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) diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs b/src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Storable/Generic/Plugin/Internal/Helpers.hs @@ -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 diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/Predicates.hs b/src/Foreign/Storable/Generic/Plugin/Internal/Predicates.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Storable/Generic/Plugin/Internal/Predicates.hs @@ -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] + diff --git a/src/Foreign/Storable/Generic/Plugin/Internal/Types.hs b/src/Foreign/Storable/Generic/Plugin/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Storable/Generic/Plugin/Internal/Types.hs @@ -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