{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiWayIf #-}
module GHC.Builtin.PrimOps.Ids
( primOpId
, allThePrimOpIds
)
where
import GHC.Prelude
import {-# SOURCE #-} GHC.Core.Opt.ConstantFold (primOpRules)
import GHC.Core.TyCo.Rep ( scaledThing )
import GHC.Core.Type
import GHC.Core.FVs (mkRuleInfo)
import GHC.Builtin.PrimOps
import GHC.Builtin.Uniques
import GHC.Builtin.Names
import GHC.Builtin.Types.Prim
import GHC.Types.Basic
import GHC.Types.Cpr
import GHC.Types.Demand
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.TyThing
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType ( ConcreteTvOrigin(..), ConcreteTyVars, TcType )
import GHC.Data.SmallArray
import Data.Maybe ( mapMaybe, listToMaybe, catMaybes, maybeToList )
mkPrimOpId :: PrimOp -> Id
mkPrimOpId :: PrimOp -> TyVar
mkPrimOpId PrimOp
prim_op
= TyVar
id
where
([TyVarBinder]
tyvars,[Type]
arg_tys,Type
res_ty, Int
arity, DmdSig
strict_sig) = PrimOp -> ([TyVarBinder], [Type], Type, Int, DmdSig)
primOpSig PrimOp
prim_op
ty :: Type
ty = [TyVarBinder] -> Type -> Type
mkForAllTys [TyVarBinder]
tyvars ([Type] -> Type -> Type
mkVisFunTysMany [Type]
arg_tys Type
res_ty)
name :: Name
name = Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name
mkWiredInName Module
gHC_PRIM (PrimOp -> OccName
primOpOcc PrimOp
prim_op)
(Int -> Unique
mkPrimOpIdUnique (PrimOp -> Int
primOpTag PrimOp
prim_op))
(TyVar -> TyThing
AnId TyVar
id) BuiltInSyntax
UserSyntax
id :: TyVar
id = IdDetails -> Name -> Type -> IdInfo -> TyVar
mkGlobalId (PrimOp -> ConcreteTyVars -> IdDetails
PrimOpId PrimOp
prim_op ConcreteTyVars
conc_tvs) Name
name Type
ty IdInfo
info
conc_tvs :: ConcreteTyVars
conc_tvs = Name -> [TyVarBinder] -> [Type] -> Type -> ConcreteTyVars
computePrimOpConcTyVarsFromType Name
name [TyVarBinder]
tyvars [Type]
arg_tys Type
res_ty
cpr :: Cpr
cpr
| Divergence -> Bool
isDeadEndDiv (([Demand], Divergence) -> Divergence
forall a b. (a, b) -> b
snd (DmdSig -> ([Demand], Divergence)
splitDmdSig DmdSig
strict_sig)) = Cpr
botCpr
| Bool
otherwise = Cpr
topCpr
info :: IdInfo
info = IdInfo
noCafIdInfo
IdInfo -> RuleInfo -> IdInfo
`setRuleInfo` [CoreRule] -> RuleInfo
mkRuleInfo (Maybe CoreRule -> [CoreRule]
forall a. Maybe a -> [a]
maybeToList (Maybe CoreRule -> [CoreRule]) -> Maybe CoreRule -> [CoreRule]
forall a b. (a -> b) -> a -> b
$ Name -> PrimOp -> Maybe CoreRule
primOpRules Name
name PrimOp
prim_op)
IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` DmdSig
strict_sig
IdInfo -> CprSig -> IdInfo
`setCprSigInfo` Int -> Cpr -> CprSig
mkCprSig Int
arity Cpr
cpr
IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
neverInlinePragma
computePrimOpConcTyVarsFromType :: Name -> [TyVarBinder] -> [Type] -> Type -> ConcreteTyVars
computePrimOpConcTyVarsFromType :: Name -> [TyVarBinder] -> [Type] -> Type -> ConcreteTyVars
computePrimOpConcTyVarsFromType Name
nm [TyVarBinder]
tyvars [Type]
arg_tys Type
_res_ty = [(Name, ConcreteTvOrigin)] -> ConcreteTyVars
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name, ConcreteTvOrigin)]
concs
where
concs :: [(Name, ConcreteTvOrigin)]
concs = [ (TyVar -> Name
tyVarName TyVar
kind_tv, FixedRuntimeRepOrigin -> ConcreteTvOrigin
ConcreteFRR FixedRuntimeRepOrigin
frr_orig)
| Bndr TyVar
tv ForAllTyFlag
_af <- [TyVarBinder]
tyvars
, TyVar
kind_tv <- Type -> [TyVar]
tyCoVarsOfTypeWellScoped (Type -> [TyVar]) -> Type -> [TyVar]
forall a b. (a -> b) -> a -> b
$ TyVar -> Type
tyVarKind TyVar
tv
, Position 'Neg
neg_pos <- Maybe (Position 'Neg) -> [Position 'Neg]
forall a. Maybe a -> [a]
maybeToList (Maybe (Position 'Neg) -> [Position 'Neg])
-> Maybe (Position 'Neg) -> [Position 'Neg]
forall a b. (a -> b) -> a -> b
$ TyVar -> Maybe (Position 'Neg)
frr_tyvar_maybe TyVar
kind_tv
, let frr_orig :: FixedRuntimeRepOrigin
frr_orig = FixedRuntimeRepOrigin
{ frr_type :: Type
frr_type = TyVar -> Type
mkTyVarTy TyVar
tv
, frr_context :: FixedRuntimeRepContext
frr_context = Name -> RepPolyId -> Position 'Neg -> FixedRuntimeRepContext
FRRRepPolyId Name
nm RepPolyId
RepPolyPrimOp Position 'Neg
neg_pos
}
]
frr_tyvar_maybe :: TyVar -> Maybe (Position 'Neg)
frr_tyvar_maybe TyVar
tv
| TyVar
tv TyVar -> [TyVar] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ TyVar
runtimeRep1TyVar, TyVar
runtimeRep2TyVar, TyVar
runtimeRep3TyVar
, TyVar
levity1TyVar, TyVar
levity2TyVar ]
= [Position 'Neg] -> Maybe (Position 'Neg)
forall a. [a] -> Maybe a
listToMaybe ([Position 'Neg] -> Maybe (Position 'Neg))
-> [Position 'Neg] -> Maybe (Position 'Neg)
forall a b. (a -> b) -> a -> b
$
((Int, Type) -> Maybe (Position 'Neg))
-> [(Int, Type)] -> [Position 'Neg]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ (Int
i,Type
arg) -> Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
forall (p :: Polarity).
Int -> Position (FlipPolarity p) -> Position p
Argument Int
i (Position 'Pos -> Position 'Neg)
-> Maybe (Position 'Pos) -> Maybe (Position 'Neg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> Type -> Maybe (Position 'Pos)
positiveKindPos_maybe TyVar
tv Type
arg)
([Int] -> [Type] -> [(Int, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Type]
arg_tys)
| Bool
otherwise
= Maybe (Position 'Neg)
forall a. Maybe a
Nothing
negativeKindPos_maybe :: TcTyVar -> TcType -> Maybe (Position Neg)
negativeKindPos_maybe :: TyVar -> Type -> Maybe (Position 'Neg)
negativeKindPos_maybe TyVar
tv Type
ty
| ([Scaled Type]
args, Type
res) <- Type -> ([Scaled Type], Type)
splitFunTys Type
ty
= [Position 'Neg] -> Maybe (Position 'Neg)
forall a. [a] -> Maybe a
listToMaybe ([Position 'Neg] -> Maybe (Position 'Neg))
-> [Position 'Neg] -> Maybe (Position 'Neg)
forall a b. (a -> b) -> a -> b
$ [Maybe (Position 'Neg)] -> [Position 'Neg]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Position 'Neg)] -> [Position 'Neg])
-> [Maybe (Position 'Neg)] -> [Position 'Neg]
forall a b. (a -> b) -> a -> b
$
( (if [Scaled Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Scaled Type]
args then Maybe (Position 'Neg)
forall a. Maybe a
Nothing else Position 'Neg -> Position 'Neg
forall (p :: Polarity). Position p -> Position p
Result (Position 'Neg -> Position 'Neg)
-> Maybe (Position 'Neg) -> Maybe (Position 'Neg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> Type -> Maybe (Position 'Neg)
negativeKindPos_maybe TyVar
tv Type
res)
Maybe (Position 'Neg)
-> [Maybe (Position 'Neg)] -> [Maybe (Position 'Neg)]
forall a. a -> [a] -> [a]
: ((Int, Scaled Type) -> Maybe (Position 'Neg))
-> [(Int, Scaled Type)] -> [Maybe (Position 'Neg)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Scaled Type) -> Maybe (Position 'Neg)
recur ([Int] -> [Scaled Type] -> [(Int, Scaled Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Scaled Type]
args)
)
where
recur :: (Int, Scaled Type) -> Maybe (Position 'Neg)
recur (Int
pos, Scaled Type
scaled_ty)
= Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
forall (p :: Polarity).
Int -> Position (FlipPolarity p) -> Position p
Argument Int
pos (Position 'Pos -> Position 'Neg)
-> Maybe (Position 'Pos) -> Maybe (Position 'Neg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> Type -> Maybe (Position 'Pos)
positiveKindPos_maybe TyVar
tv (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
scaled_ty)
positiveKindPos_maybe :: TcTyVar -> TcType -> Maybe (Position Pos)
positiveKindPos_maybe :: TyVar -> Type -> Maybe (Position 'Pos)
positiveKindPos_maybe TyVar
tv Type
ty
| ([Scaled Type]
args, Type
res) <- Type -> ([Scaled Type], Type)
splitFunTys Type
ty
= [Position 'Pos] -> Maybe (Position 'Pos)
forall a. [a] -> Maybe a
listToMaybe ([Position 'Pos] -> Maybe (Position 'Pos))
-> [Position 'Pos] -> Maybe (Position 'Pos)
forall a b. (a -> b) -> a -> b
$ [Maybe (Position 'Pos)] -> [Position 'Pos]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Position 'Pos)] -> [Position 'Pos])
-> [Maybe (Position 'Pos)] -> [Position 'Pos]
forall a b. (a -> b) -> a -> b
$
( (if [Scaled Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Scaled Type]
args then Type -> Maybe (Position 'Pos)
finish Type
res else Position 'Pos -> Position 'Pos
forall (p :: Polarity). Position p -> Position p
Result (Position 'Pos -> Position 'Pos)
-> Maybe (Position 'Pos) -> Maybe (Position 'Pos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> Type -> Maybe (Position 'Pos)
positiveKindPos_maybe TyVar
tv Type
res)
Maybe (Position 'Pos)
-> [Maybe (Position 'Pos)] -> [Maybe (Position 'Pos)]
forall a. a -> [a] -> [a]
: ((Int, Scaled Type) -> Maybe (Position 'Pos))
-> [(Int, Scaled Type)] -> [Maybe (Position 'Pos)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Scaled Type) -> Maybe (Position 'Pos)
recur ([Int] -> [Scaled Type] -> [(Int, Scaled Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Scaled Type]
args)
)
where
recur :: (Int, Scaled Type) -> Maybe (Position 'Pos)
recur (Int
pos, Scaled Type
scaled_ty)
= Int -> Position (FlipPolarity 'Pos) -> Position 'Pos
forall (p :: Polarity).
Int -> Position (FlipPolarity p) -> Position p
Argument Int
pos (Position 'Neg -> Position 'Pos)
-> Maybe (Position 'Neg) -> Maybe (Position 'Pos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> Type -> Maybe (Position 'Neg)
negativeKindPos_maybe TyVar
tv (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
scaled_ty)
finish :: Type -> Maybe (Position 'Pos)
finish Type
ty
| TyVar
tv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty)
= Position 'Pos -> Maybe (Position 'Pos)
forall a. a -> Maybe a
Just Position 'Pos
Top
| Bool
otherwise
= Maybe (Position 'Pos)
forall a. Maybe a
Nothing
primOpIds :: SmallArray Id
{-# NOINLINE primOpIds #-}
primOpIds :: SmallArray TyVar
primOpIds = Int
-> (PrimOp -> Int)
-> (PrimOp -> TyVar)
-> [PrimOp]
-> SmallArray TyVar
forall e a. Int -> (e -> Int) -> (e -> a) -> [e] -> SmallArray a
listToArray (Int
maxPrimOpTagInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) PrimOp -> Int
primOpTag PrimOp -> TyVar
mkPrimOpId [PrimOp]
allThePrimOps
primOpId :: PrimOp -> Id
{-# INLINE primOpId #-}
primOpId :: PrimOp -> TyVar
primOpId PrimOp
op = SmallArray TyVar -> Int -> TyVar
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray TyVar
primOpIds (PrimOp -> Int
primOpTag PrimOp
op)
allThePrimOpIds :: [Id]
{-# INLINE allThePrimOpIds #-}
allThePrimOpIds :: [TyVar]
allThePrimOpIds = (Int -> TyVar) -> [Int] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map (SmallArray TyVar -> Int -> TyVar
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray TyVar
primOpIds) [Int
0..Int
maxPrimOpTag]