{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiWayIf #-}

-- | PrimOp's Ids
module GHC.Builtin.PrimOps.Ids
  ( primOpId
  , allThePrimOpIds
  )
where

import GHC.Prelude

-- primop rules are attached to primop ids
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 )


-- | Build a PrimOp Id
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

    -- PrimOps don't ever construct a product, but we want to preserve bottoms
    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
               -- We give PrimOps a NOINLINE pragma so that we don't
               -- get silly warnings from Desugar.dsRule (the inline_shadows_rule
               -- test) about a RULE conflicting with a possible inlining
               -- cf #7287

-- | Analyse the type of a primop to determine which of its outermost forall'd
-- type variables must be instantiated to concrete types when the primop is
-- instantiated.
--
-- These are the Levity and RuntimeRep kinded type-variables which appear in
-- negative position in the type of the primop.
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
                           }
            ]

    -- As per Note [Levity and representation polymorphic primops]
    -- in GHC.Builtin.Primops.txt.pp, we compute the ConcreteTyVars associated
    -- to a primop by inspecting the type variable names.
    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
      -- Compute whether the type variable occurs in the kind of a type variable
      -- in positive position in one of the argument types of the primop.

-- | Does this type variable appear in a kind in a negative position in the
-- type?
--
-- Returns the first such position if so.
--
-- NB: assumes the type is of a simple form, e.g. no foralls, no function
-- arrows nested in a TyCon other than a function arrow.
-- Just used to compute the set of ConcreteTyVars for a PrimOp by inspecting
-- its type, see 'computePrimOpConcTyVarsFromType'.
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)
    -- (assumes we don't have any function types nested inside other types)

-- | Does this type variable appear in a kind in a positive position in the
-- type?
--
-- Returns the first such position if so.
--
-- NB: assumes the type is of a simple form, e.g. no foralls, no function
-- arrows nested in a TyCon other than a function arrow.
-- Just used to compute the set of ConcreteTyVars for a PrimOp by inspecting
-- its type, see 'computePrimOpConcTyVarsFromType'.
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)
    -- (assumes we don't have any function types nested inside other types)
    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

-------------------------------------------------------------
-- Cache of PrimOp's Ids
-------------------------------------------------------------

-- | A cache of the PrimOp Ids, indexed by PrimOp tag (0 indexed)
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

-- | Get primop id.
--
-- Retrieve it from `primOpIds` cache.
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)

-- | All the primop ids, as a list
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]