module GHC.Builtin.PrimOps (

         PrimOp(..), PrimOpVecCat(..), allThePrimOps,

         primOpTag, maxPrimOpTag, primOpOcc,

         primOpWrapperId,

         pprPrimOp,

         -- this function isn't exported.

 #include "primop-strictness.hs-incl"

 {-

 ************************************************************************

 *                                                                      *

    div_like         = False   -- Second argument expected to be non zero - used for tests

    shift_like       = False   -- Second argument expected to be atmost first argument's word size -1 - used for tests

    defined_bits     = Nothing -- The number of bits the operation is defined for (if not all bits)

 -- Note [When do out-of-line primops go in primops.txt.pp]

 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    effect = ReadWriteEffect

    can_fail_warning = YesWarnCanFail

 primop  WriteArrayOp "writeArray#" GenPrimOp

    MutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s

    {Write to specified index of mutable array.}

    can_fail_warning = YesWarnCanFail

    code_size = 2 -- card update too

 primop  SizeofArrayOp "sizeofArray#" GenPrimOp

    Array# a_levpoly -> Int#

    {Return the number of elements in the array.}

    MutableArray# s a_levpoly -> Int#

    {Return the number of elements in the array.}

 primop  IndexArrayOp "indexArray#" GenPrimOp

    Array# a_levpoly -> Int# -> (# a_levpoly #)

    {Read from the specified index of an immutable array. The result is packaged

    effect = ReadWriteEffect

    can_fail_warning = YesWarnCanFail

 primop  WriteSmallArrayOp "writeSmallArray#" GenPrimOp

    SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s

    {Write to specified index of mutable array.}

    effect = ReadWriteEffect

    can_fail_warning = YesWarnCanFail

 primop  SizeofSmallArrayOp "sizeofSmallArray#" GenPrimOp

    SmallArray# a_levpoly -> Int#

    {Return the number of elements in the array.}

    with

    effect = CanFail

 primop  UnsafeFreezeSmallArrayOp "unsafeFreezeSmallArray#" GenPrimOp

    SmallMutableArray# s a_levpoly -> State# s -> (# State# s, SmallArray# a_levpoly #)

    {Make a mutable array immutable, without copying.}

 import GHC.Prelude hiding (id)

 import GHC.Core.DataCon

 import GHC.Core.Type

 import GHC.Types.Id

   -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $

   snd (mapAccumL inferTagTopBind (initEnv for_bytecode) binds)

 -----------------------

 inferTagTopBind :: TagEnv 'CodeGen -> GenStgTopBinding 'CodeGen

                 -> (TagEnv 'CodeGen, GenStgTopBinding 'InferTaggedBinders)

   where

     (info, body') = inferTagExpr env body

   -- Which primops guarantee to return a properly tagged value?

   -- Probably none, and that is the conservative assumption anyway.

   -- (And foreign calls definitely need not make promises.)

 inferTagExpr env (StgLet ext bind body)

   = (info, StgLet ext bind' body')

 import GHC.Prelude

 import GHC.Types.Basic     ( CbvMark (..), isMarkedCbv

                            , TopLevelFlag(..), isTopLevel )

 import GHC.Types.Id

 rewriteExpr e@(StgConApp {})          = rewriteConApp e

 rewriteExpr e@(StgApp {})             = rewriteApp e

 rewriteExpr (StgLit lit)              = return $! (StgLit lit)

 rewriteCase :: InferStgExpr -> RM TgStgExpr

 rewriteCase (StgCase scrut bndr alt_type alts) =

 rewriteConApp _ = panic "Impossible"

 -- Special case: Atomic binders, usually in a case context like `case f of ...`.

 rewriteApp :: InferStgExpr -> RM TgStgExpr

 rewriteApp (StgApp f []) = do

     , relevant_marks <- dropWhileEndLE (not . isMarkedCbv) marks

     , any isMarkedCbv relevant_marks

     = assertPpr (length relevant_marks <= length args) (ppr f $$ ppr args $$ ppr relevant_marks)

 rewriteApp (StgApp f args) = return $ StgApp f args

 rewriteApp _ = panic "Impossible"

 rewriteOpApp :: InferStgExpr -> RM TgStgExpr

 rewriteOpApp (StgOpApp op args res_ty) = case op of

   op@(StgPrimOp primOp)

     | primOp == DataToTagSmallOp || primOp == DataToTagLargeOp

     -- see Note [Rewriting primop arguments]

     -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty

   _ -> pure $! StgOpApp op args res_ty

 rewriteOpApp _ = panic "Impossible"

   ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->

     doReadPtrArrayOp res obj ix

   IndexArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->

     doReadPtrArrayOp res obj ix

   WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] ->

     doWritePtrArrayOp obj ix v

   ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->

     doReadSmallPtrArrayOp res obj ix

   IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->

     doReadSmallPtrArrayOp res obj ix

   WriteSmallArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] ->

     doWriteSmallPtrArrayOp obj ix v

 -- Getting the size of pointer arrays

   NewArrayOp           -> \[r] [l,e]   -> pure $ PrimInline $ r |= app hdNewArrayStr [l,e]

   ReadArrayOp          -> \[r] [a,i]   -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i)

   WriteArrayOp         -> \[]  [a,i,v] -> pure $ PrimInline $ bnd_arr bound a i (a .! i |= v)

   SizeofArrayOp        -> \[r] [a]     -> pure $ PrimInline $ r |= a .^ lngth

   SizeofMutableArrayOp -> \[r] [a]     -> pure $ PrimInline $ r |= a .^ lngth

   IndexArrayOp         -> \[r] [a,i]   -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i)

   NewSmallArrayOp            -> \[a]   [n,e]         -> pure $ PrimInline $ a |= app hdNewArrayStr [n,e]

   ReadSmallArrayOp           -> \[r]   [a,i]         -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i)

   WriteSmallArrayOp          -> \[]    [a,i,e]       -> pure $ PrimInline $ bnd_arr bound a i (a .! i |= e)

   SizeofSmallArrayOp         -> \[r]   [a]           -> pure $ PrimInline $ r |= a .^ lngth

   SizeofSmallMutableArrayOp  -> \[r]   [a]           -> pure $ PrimInline $ r |= a .^ lngth

   IndexSmallArrayOp          -> \[r]   [a,i]         -> pure $ PrimInline $ bnd_arr bound a i (r |= a .! i)

                         _         -> False

 isPrimOpId_maybe id = case Var.idDetails id of

 isFCallId id = case Var.idDetails id of

                         FCallId _ -> True

 idCbvMarks_maybe :: Id -> Maybe [CbvMark]

 idCbvMarks_maybe id = case idDetails id of

   JoinId _arity marks  -> marks

   _                    -> Nothing

 pprIdDetails other     = brackets (pp other)

  where

    pp VanillaId               = panic "pprIdDetails"

    pp (DataConWorkId _)       = text "DataCon"

    pp (DataConWrapId _)       = text "DataConWrapper"

    pp (ClassOpId {})          = text "ClassOp"

    pp CoVarId                 = text "CoVarId"

    pp (JoinId arity marks)    = text "JoinId" <> parens (int arity) <> parens (ppr marks)

 {-

 ************************************************************************

 *                                                                      *

     , ("primop-commutable.hs-incl"        , "--commutable")

     , ("primop-code-size.hs-incl"         , "--code-size")

     , ("primop-strictness.hs-incl"        , "--strictness")

     , ("primop-is-work-free.hs-incl"      , "--is-work-free")

     , ("primop-is-cheap.hs-incl"          , "--is-cheap")

     , ("primop-fixity.hs-incl"            , "--fixity")

                   , "primop-out-of-line.hs-incl"

                   , "primop-primop-info.hs-incl"

                   , "primop-strictness.hs-incl"

                   , "primop-is-work-free.hs-incl"

                   , "primop-is-cheap.hs-incl"

                   , "primop-tag.hs-incl"

                , path </> "primop-tag.hs-incl"

                , path </> "primop-list.hs-incl"

                , path </> "primop-strictness.hs-incl"

                , path </> "primop-is-work-free.hs-incl"

                , path </> "primop-is-cheap.hs-incl"

                , path </> "primop-fixity.hs-incl"

     , output "//primop-commutable.hs-incl"         ? arg "--commutable"

     , output "//primop-code-size.hs-incl"          ? arg "--code-size"

     , output "//primop-strictness.hs-incl"         ? arg "--strictness"

     , output "//primop-is-work-free.hs-incl"       ? arg "--is-work-free"

     , output "//primop-is-cheap.hs-incl"           ? arg "--is-cheap"

     , output "//primop-fixity.hs-incl"             ? arg "--fixity"

     <0>         "]"                 { mkT TCloseBracket }

     <0>         "<"                 { mkT TOpenAngle }

     <0>         ">"                 { mkT TCloseAngle }

     <0>         "section"           { mkT TSection }

     <0>         "primop"            { mkT TPrimop }

     <0>         "pseudoop"          { mkT TPseudoop }

     <0>         "WarnIfEffectIsCanFail" { mkT TWarnIfEffectIsCanFail }

     <0>         "YesWarnCanFail"    { mkT TYesWarnCanFail }

     <0>         "vector"            { mkT TVector }

     <0>         "bytearray_access_ops" { mkT TByteArrayAccessOps }

     <0>         "addr_access_ops"   { mkT TAddrAccessOps }

     <0>         "thats_all_folks"   { mkT TThatsAllFolks }

                                        "strictness"

                                        "primOpStrictness" p_o_specs)

                       "--fixity"

                          -> putStr (gen_switch_from_attribs

                                        "fixity"

        "--is-work-free",

        "--is-cheap",

        "--strictness",

        "--fixity",

        "--primop-effects",

        "--primop-primop-info",

            opt (OptionInteger n v) = n ++ " = " ++ show v

            opt (OptionVector _)    = ""

            opt (OptionFixity mf) = "fixity = " ++ show mf

            opt (OptionEffect eff) = "effect = " ++ show eff

            opt (OptionDefinedBits bc) = "defined_bits = " ++ show bc

            opt (OptionCanFailWarnFlag wf) = "can_fail_warning = " ++ show wf

          getAltRhs (OptionString _ s) = s

          getAltRhs (OptionVector _) = "True"

          getAltRhs (OptionFixity mf) = show mf

          getAltRhs (OptionEffect eff) = show eff

          getAltRhs (OptionDefinedBits bc) = show bc

          getAltRhs (OptionCanFailWarnFlag wf) = show wf

     ']'             { TCloseBracket }

     '<'             { TOpenAngle }

     '>'             { TCloseAngle }

     section         { TSection }

     primop          { TPrimop }

     pseudoop        { TPseudoop }

     WarnIfEffectIsCanFail { TWarnIfEffectIsCanFail }

     YesWarnCanFail  { TYesWarnCanFail }

     vector          { TVector }

     SCALAR          { TSCALAR }

     VECTOR          { TVECTOR }

     VECTUPLE        { TVECTUPLE }

         | lowerName        '=' pStuffBetweenBraces    { OptionString  $1  $3 }

         | lowerName        '=' integer                { OptionInteger $1  $3 }

         | vector           '=' pVectorTemplate        { OptionVector      $3 }

         | fixity           '=' pInfix                 { OptionFixity      $3 }

         | effect           '=' pEffect                { OptionEffect      $3 }

         | defined_bits     '=' pGoodBits              { OptionDefinedBits $3 }

 pInside : '{' pInsides '}' { "{" ++ $2 ++ "}" }

         | noBraces         { $1 }

 pVectorTemplate :: { [(String, String, Int)] }

 pVectorTemplate : '[' pVectors ']' { $2 }

 data Token = TEOF

            | TArrow

            | TDArrow

            | TEquals

            | TComma

            | TWarnIfEffectIsCanFail

            | TYesWarnCanFail

            | TVector

            | TSCALAR

            | TVECTOR

            | TVECTUPLE

    | OptionEffect PrimOpEffect    -- effect = NoEffect | DoNotSpeculate | CanFail | ThrowsException | ReadWriteEffect | FallibleReadWriteEffect

    | OptionCanFailWarnFlag PrimOpCanFailWarnFlag -- can_fail_warning = DoNotWarnCanFail | WarnIfEffectIsCanFail | YesWarnCanFail

    | OptionDefinedBits (Maybe Word) -- defined_bits = Just 16 | Nothing

      deriving Show

 -- categorises primops

 get_attrib_name (OptionString nm _) = nm

 get_attrib_name (OptionInteger nm _) = nm

 get_attrib_name (OptionVector _) = "vector"

 get_attrib_name (OptionFixity _) = "fixity"

 get_attrib_name (OptionEffect _) = "effect"

 get_attrib_name (OptionCanFailWarnFlag _) = "can_fail_warning"