{-# LANGUAGE CPP #-}
module Foreign.Storable.Generic.Plugin.Internal.GroupTypes
(
calcGroupOrder
, substituteTyCon
, getDataConArgs
, groupBinds
)
where
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
import GHC.Core (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt)
import GHC.Types.Literal (Literal(..))
import GHC.Types.Id (isLocalId, isGlobalId,Id)
import GHC.Types.Var (Var(..))
import GHC.Types.Name (getOccName,mkOccName)
import GHC.Types.Name.Occurrence (OccName(..), occNameString)
import qualified GHC.Types.Name as N (varName)
import GHC.Types.SrcLoc (noSrcSpan)
import GHC.Types.Unique (getUnique)
import GHC.Driver.Main (hscCompileCoreExpr, getHscEnv)
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
import GHC.Driver.Env.Types (HscEnv)
import GHC.Unit.Module.ModGuts (ModGuts(..))
#else
import GHC.Driver.Types (HscEnv,ModGuts(..))
#endif
import GHC.Core.Opt.Monad (CoreM,CoreToDo(..))
import GHC.Types.Basic (CompilerPhase(..))
import GHC.Core.Type hiding (eqType)
import GHC.Core.TyCon
import GHC.Builtin.Types (intDataCon)
import GHC.Core.DataCon (dataConWorkId,dataConOrigArgTys)
import GHC.Core.Make (mkWildValBinder)
import GHC.Utils.Outputable (cat, ppr, SDoc, showSDocUnsafe)
import GHC.Utils.Outputable (text, (<+>), ($$), nest)
import GHC.Core.Opt.Monad (putMsg, putMsgS)
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
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)
import HscMain (hscCompileCoreExpr)
import HscTypes (HscEnv,ModGuts(..))
import CoreMonad (CoreM,CoreToDo(..), getHscEnv)
import BasicTypes (CompilerPhase(..))
import Type hiding (eqType)
import TyCon
import TysWiredIn (intDataCon)
import DataCon (dataConWorkId,dataConOrigArgTys)
import MkCore (mkWildValBinder)
import Outputable (cat, ppr, SDoc, showSDocUnsafe)
import Outputable (text, (<+>), ($$), nest)
import CoreMonad (putMsg, putMsgS)
#endif
import GHCi.RemoteTypes
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
import GHC.Types.Var (TyVarBinder(..), VarBndr(..))
import GHC.Core.TyCo.Rep (Type(..), TyBinder(..), TyCoBinder(..),scaledThing)
import GHC.Types.Var
#elif MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
import Var (TyVarBinder(..), VarBndr(..))
import TyCoRep (Type(..), TyBinder(..), TyCoBinder(..))
import Var
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
import Var (TyVarBndr(..), TyVarBinder)
import TyCoRep (Type(..), TyBinder(..))
import Var
#endif
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
calcGroupOrder :: [Type] -> ([[Type]], Maybe Error)
calcGroupOrder :: [Type] -> ([[Type]], Maybe Error)
calcGroupOrder [Type]
types = [Type] -> [[Type]] -> ([[Type]], Maybe Error)
calcGroupOrder_rec [Type]
types []
calcGroupOrder_rec :: [Type]
-> [[Type]]
-> ([[Type]], Maybe Error)
calcGroupOrder_rec :: [Type] -> [[Type]] -> ([[Type]], Maybe Error)
calcGroupOrder_rec [] [[Type]]
acc = ([[Type]] -> [[Type]]
forall a. [a] -> [a]
reverse [[Type]]
acc, Maybe Error
forall a. Maybe a
Nothing)
calcGroupOrder_rec [Type]
types [[Type]]
acc = do
let ([Type]
layer, [Type]
rest) = [Type] -> [Type] -> [Type] -> [Type] -> ([Type], [Type])
calcGroupOrder_iteration [Type]
types [] [] []
layer' :: [Type]
layer' = (Type -> Type -> Bool) -> [Type] -> [Type]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy Type -> Type -> Bool
eqType [Type]
layer
if [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
layer' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then ([[Type]] -> [[Type]]
forall a. [a] -> [a]
reverse [[Type]]
acc, Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ Int -> [Type] -> Error
OrderingFailedTypes ([[Type]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Type]]
acc) [Type]
rest)
else [Type] -> [[Type]] -> ([[Type]], Maybe Error)
calcGroupOrder_rec [Type]
rest ([Type]
layer'[Type] -> [[Type]] -> [[Type]]
forall a. a -> [a] -> [a]
:[[Type]]
acc)
calcGroupOrder_iteration :: [Type]
-> [Type]
-> [Type]
-> [Type]
-> ([Type], [Type])
calcGroupOrder_iteration :: [Type] -> [Type] -> [Type] -> [Type] -> ([Type], [Type])
calcGroupOrder_iteration [] [Type]
checked [Type]
accepted [Type]
rejected = ([Type]
accepted, [Type]
rejected)
calcGroupOrder_iteration (Type
t:[Type]
ts) [Type]
checked [Type]
accepted [Type]
rejected = do
let args :: [Type]
args = Type -> [Type]
getDataConArgs Type
t
is_arg_somewhere :: Bool
is_arg_somewhere = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Type
t -> Type -> [Type] -> Bool
elemType Type
t [Type]
args) [Type]
checked Bool -> Bool -> Bool
|| (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Type
t -> Type -> [Type] -> Bool
elemType Type
t [Type]
args) [Type]
ts
if Bool
is_arg_somewhere
then [Type] -> [Type] -> [Type] -> [Type] -> ([Type], [Type])
calcGroupOrder_iteration [Type]
ts (Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
checked) [Type]
accepted (Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
rejected)
else [Type] -> [Type] -> [Type] -> [Type] -> ([Type], [Type])
calcGroupOrder_iteration [Type]
ts (Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
checked) (Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
accepted) [Type]
rejected
type TypeScope = (TyVar, Type)
substituteTyCon :: [TypeScope] -> Type -> Type
substituteTyCon :: [TypeScope] -> Type -> Type
substituteTyCon [] Type
tc_app = Type
tc_app
substituteTyCon [TypeScope]
type_scope old :: Type
old@(TyVarTy Var
ty_var)
= case (TypeScope -> Bool) -> [TypeScope] -> Maybe TypeScope
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Var
av,Type
_) -> Var
av Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
ty_var) [TypeScope]
type_scope of
Just (Var
_, Type
new_type) -> Type
new_type
Maybe TypeScope
Nothing -> Type
old
substituteTyCon [TypeScope]
type_scope (TyConApp TyCon
tc [Type]
args)
= TyCon -> [Type] -> Type
TyConApp TyCon
tc ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([TypeScope] -> Type -> Type
substituteTyCon [TypeScope]
type_scope) [Type]
args
substituteTyCon [TypeScope]
type_scope Type
t = Type
t
getDataConArgs :: Type -> [Type]
getDataConArgs :: Type -> [Type]
getDataConArgs Type
t
| Type -> Bool
isAlgType Type
t
, Just (TyCon
tc, [Type]
ty_args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t
, [Var]
ty_vars <- TyCon -> [Var]
tyConTyVars TyCon
tc
= do
let type_scope :: [TypeScope]
type_scope = [Var] -> [Type] -> [TypeScope]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
ty_vars [Type]
ty_args
data_cons :: [Scaled Type]
data_cons = (DataCon -> [Scaled Type]) -> [DataCon] -> [Scaled Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DataCon -> [Scaled Type]
dataConOrigArgTys ([DataCon] -> [Scaled Type]) -> [DataCon] -> [Scaled Type]
forall a b. (a -> b) -> a -> b
$ (AlgTyConRhs -> [DataCon]
visibleDataCons(AlgTyConRhs -> [DataCon])
-> (TyCon -> AlgTyConRhs) -> TyCon -> [DataCon]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.TyCon -> AlgTyConRhs
algTyConRhs) TyCon
tc
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
(Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ([TypeScope] -> Type -> Type
substituteTyCon [TypeScope]
type_scope) ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
data_cons)
#else
map (substituteTyCon type_scope) data_cons
#endif
| Bool
otherwise = []
groupBinds :: [[Type]]
-> [CoreBind]
-> ([[CoreBind]], Maybe Error)
groupBinds :: [[Type]] -> [CoreBind] -> ([[CoreBind]], Maybe Error)
groupBinds [[Type]]
type_groups [CoreBind]
binds = [[Type]]
-> [CoreBind] -> [[CoreBind]] -> ([[CoreBind]], Maybe Error)
groupBinds_rec [[Type]]
type_groups [CoreBind]
binds []
groupBinds_rec :: [[Type]]
-> [CoreBind]
-> [[CoreBind]]
-> ([[CoreBind]], Maybe Error)
groupBinds_rec :: [[Type]]
-> [CoreBind] -> [[CoreBind]] -> ([[CoreBind]], Maybe Error)
groupBinds_rec [] [] [[CoreBind]]
acc = ([[CoreBind]] -> [[CoreBind]]
forall a. [a] -> [a]
reverse [[CoreBind]]
acc,Maybe Error
forall a. Maybe a
Nothing)
groupBinds_rec ([Type]
a:[[Type]]
as) [] [[CoreBind]]
acc = ([[CoreBind]] -> [[CoreBind]]
forall a. [a] -> [a]
reverse [[CoreBind]]
acc,Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ SDoc -> Error
OtherError SDoc
msg)
where msg :: SDoc
msg = String -> SDoc
text String
"Could not find any bindings."
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Is the second pass placed after main simplifier phases ?"
groupBinds_rec [] [CoreBind]
binds [[CoreBind]]
acc = ([[CoreBind]] -> [[CoreBind]]
forall a. [a] -> [a]
reverse [[CoreBind]]
acc,Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ Int -> [CoreBind] -> Error
OrderingFailedBinds ([[CoreBind]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[CoreBind]]
acc) [CoreBind]
binds)
groupBinds_rec ([Type]
tg:[[Type]]
tgs) [CoreBind]
binds [[CoreBind]]
acc = do
let predicate :: CoreBind -> Bool
predicate (NonRec Var
id Expr Var
_) = case Type -> Maybe Type
getGStorableType (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
id of
Just Type
t -> Type
t Type -> [Type] -> Bool
`elemType` [Type]
tg
Maybe Type
Nothing -> Bool
False
predicate (Rec [(Var, Expr Var)]
_) = Bool
False
let ([CoreBind]
layer, [CoreBind]
rest) = (CoreBind -> Bool) -> [CoreBind] -> ([CoreBind], [CoreBind])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition CoreBind -> Bool
predicate [CoreBind]
binds
if [CoreBind] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreBind]
layer Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then ([[CoreBind]] -> [[CoreBind]]
forall a. [a] -> [a]
reverse [[CoreBind]]
acc, Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ Int -> [CoreBind] -> Error
OrderingFailedBinds ([[CoreBind]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[CoreBind]]
acc) [CoreBind]
rest)
else [[Type]]
-> [CoreBind] -> [[CoreBind]] -> ([[CoreBind]], Maybe Error)
groupBinds_rec [[Type]]
tgs [CoreBind]
rest ([CoreBind] -> [CoreBind]
forall a. [a] -> [a]
reverse [CoreBind]
layer[CoreBind] -> [[CoreBind]] -> [[CoreBind]]
forall a. a -> [a] -> [a]
:[[CoreBind]]
acc)