    {-# 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]