{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1998


This module contains definitions for the IdInfo for things that
have a standard form, namely:

- data constructors
- record selectors
- method and superclass selectors
- primitive operations
-}

{-# LANGUAGE CPP #-}

module MkId (
        mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs,

        mkPrimOpId, mkFCallId,

        unwrapNewTypeBody, wrapFamInstBody,
        DataConBoxer(..), mkDataConRep, mkDataConWorkId,

        -- And some particular Ids; see below for why they are wired in
        wiredInIds, ghcPrimIds,
        unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
        voidPrimId, voidArgId,
        nullAddrId, seqId, lazyId, lazyIdKey,
        coercionTokenId, magicDictId, coerceId,
        proxyHashId, noinlineId, noinlineIdName,

        -- Re-export error Ids
        module PrelRules
    ) where

#include "HsVersions.h"

import GhcPrelude

import Rules
import TysPrim
import TysWiredIn
import PrelRules
import Type
import FamInstEnv
import Coercion
import TcType
import MkCore
import CoreUtils        ( exprType, mkCast )
import CoreUnfold
import Literal
import TyCon
import Class
import NameSet
import Name
import PrimOp
import ForeignCall
import DataCon
import Id
import IdInfo
import Demand
import CoreSyn
import Unique
import UniqSupply
import PrelNames
import BasicTypes       hiding ( SuccessFlag(..) )
import Util
import Pair
import DynFlags
import Outputable
import FastString
import ListSetOps
import qualified GHC.LanguageExtensions as LangExt

import Data.Maybe       ( maybeToList )

{-
************************************************************************
*                                                                      *
\subsection{Wired in Ids}
*                                                                      *
************************************************************************

Note [Wired-in Ids]
~~~~~~~~~~~~~~~~~~~
A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId')
rather than by looking it up its name in some environment or fetching
it from an interface file.

There are several reasons why an Id might appear in the wiredInIds:

* ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)]

* magicIds: see Note [magicIds]

* errorIds, defined in coreSyn/MkCore.hs.
  These error functions (e.g. rUNTIME_ERROR_ID) are wired in
  because the desugarer generates code that mentions them directly

In all cases except ghcPrimIds, there is a definition site in a
library module, which may be called (e.g. in higher order situations);
but the wired-in version means that the details are never read from
that module's interface file; instead, the full definition is right
here.

Note [ghcPrimIds (aka pseudoops)]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The ghcPrimIds

  * Are exported from GHC.Prim

  * Can't be defined in Haskell, and hence no Haskell binding site,
    but have perfectly reasonable unfoldings in Core

  * Either have a CompulsoryUnfolding (hence always inlined), or
        of an EvaldUnfolding and void representation (e.g. void#)

  * Are (or should be) defined in primops.txt.pp as 'pseudoop'
    Reason: that's how we generate documentation for them

Note [magicIds]
~~~~~~~~~~~~~~~
The magicIds

  * Are exported from GHC.Magic

  * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs).
    This definition at least generates Haddock documentation for them.

  * May or may not have a CompulsoryUnfolding.

  * But have some special behaviour that can't be done via an
    unfolding from an interface file
-}

wiredInIds :: [Id]
wiredInIds :: [Id]
wiredInIds
  =  [Id]
magicIds
  [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
ghcPrimIds
  [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
errorIds           -- Defined in MkCore

magicIds :: [Id]    -- See Note [magicIds]
magicIds :: [Id]
magicIds = [Id
lazyId, Id
oneShotId, Id
noinlineId]

ghcPrimIds :: [Id]  -- See Note [ghcPrimIds (aka pseudoops)]
ghcPrimIds :: [Id]
ghcPrimIds
  = [ Id
realWorldPrimId
    , Id
voidPrimId
    , Id
unsafeCoerceId
    , Id
nullAddrId
    , Id
seqId
    , Id
magicDictId
    , Id
coerceId
    , Id
proxyHashId
    ]

{-
************************************************************************
*                                                                      *
\subsection{Data constructors}
*                                                                      *
************************************************************************

The wrapper for a constructor is an ordinary top-level binding that evaluates
any strict args, unboxes any args that are going to be flattened, and calls
the worker.

We're going to build a constructor that looks like:

        data (Data a, C b) =>  T a b = T1 !a !Int b

        T1 = /\ a b ->
             \d1::Data a, d2::C b ->
             \p q r -> case p of { p ->
                       case q of { q ->
                       Con T1 [a,b] [p,q,r]}}

Notice that

* d2 is thrown away --- a context in a data decl is used to make sure
  one *could* construct dictionaries at the site the constructor
  is used, but the dictionary isn't actually used.

* We have to check that we can construct Data dictionaries for
  the types a and Int.  Once we've done that we can throw d1 away too.

* We use (case p of q -> ...) to evaluate p, rather than "seq" because
  all that matters is that the arguments are evaluated.  "seq" is
  very careful to preserve evaluation order, which we don't need
  to be here.

  You might think that we could simply give constructors some strictness
  info, like PrimOps, and let CoreToStg do the let-to-case transformation.
  But we don't do that because in the case of primops and functions strictness
  is a *property* not a *requirement*.  In the case of constructors we need to
  do something active to evaluate the argument.

  Making an explicit case expression allows the simplifier to eliminate
  it in the (common) case where the constructor arg is already evaluated.

Note [Wrappers for data instance tycons]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the case of data instances, the wrapper also applies the coercion turning
the representation type into the family instance type to cast the result of
the wrapper.  For example, consider the declarations

  data family Map k :: * -> *
  data instance Map (a, b) v = MapPair (Map a (Pair b v))

The tycon to which the datacon MapPair belongs gets a unique internal
name of the form :R123Map, and we call it the representation tycon.
In contrast, Map is the family tycon (accessible via
tyConFamInst_maybe). A coercion allows you to move between
representation and family type.  It is accessible from :R123Map via
tyConFamilyCoercion_maybe and has kind

  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}

The wrapper and worker of MapPair get the types

        -- Wrapper
  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
  $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v)

        -- Worker
  MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v

This coercion is conditionally applied by wrapFamInstBody.

It's a bit more complicated if the data instance is a GADT as well!

   data instance T [a] where
        T1 :: forall b. b -> T [Maybe b]

Hence we translate to

        -- Wrapper
  $WT1 :: forall b. b -> T [Maybe b]
  $WT1 b v = T1 (Maybe b) b (Maybe b) v
                        `cast` sym (Co7T (Maybe b))

        -- Worker
  T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c

        -- Coercion from family type to representation type
  Co7T a :: T [a] ~ :R7T a

Newtype instances through an additional wrinkle into the mix. Consider the
following example (adapted from #15318, comment:2):

  data family T a
  newtype instance T [a] = MkT [a]

Within the newtype instance, there are three distinct types at play:

1. The newtype's underlying type, [a].
2. The instance's representation type, TList a (where TList is the
   representation tycon).
3. The family type, T [a].

We need two coercions in order to cast from (1) to (3):

(a) A newtype coercion axiom:

      axiom coTList a :: TList a ~ [a]

    (Where TList is the representation tycon of the newtype instance.)

(b) A data family instance coercion axiom:

      axiom coT a :: T [a] ~ TList a

When we translate the newtype instance to Core, we obtain:

    -- Wrapper
  $WMkT :: forall a. [a] -> T [a]
  $WMkT a x = MkT a x |> Sym (coT a)

    -- Worker
  MkT :: forall a. [a] -> TList [a]
  MkT a x = x |> Sym (coTList a)

Unlike for data instances, the worker for a newtype instance is actually an
executable function which expands to a cast, but otherwise, the general
strategy is essentially the same as for data instances. Also note that we have
a wrapper, which is unusual for a newtype, but we make GHC produce one anyway
for symmetry with the way data instances are handled.

Note [Newtype datacons]
~~~~~~~~~~~~~~~~~~~~~~~
The "data constructor" for a newtype should always be vanilla.  At one
point this wasn't true, because the newtype arising from
     class C a => D a
looked like
       newtype T:D a = D:D (C a)
so the data constructor for T:C had a single argument, namely the
predicate (C a).  But now we treat that as an ordinary argument, not
part of the theta-type, so all is well.


************************************************************************
*                                                                      *
\subsection{Dictionary selectors}
*                                                                      *
************************************************************************

Selecting a field for a dictionary.  If there is just one field, then
there's nothing to do.

Dictionary selectors may get nested forall-types.  Thus:

        class Foo a where
          op :: forall b. Ord b => a -> b -> b

Then the top-level type for op is

        op :: forall a. Foo a =>
              forall b. Ord b =>
              a -> b -> b

-}

mkDictSelId :: Name          -- Name of one of the *value* selectors
                             -- (dictionary superclass or method)
            -> Class -> Id
mkDictSelId :: Name -> Class -> Id
mkDictSelId name :: Name
name clas :: Class
clas
  = IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId (Class -> IdDetails
ClassOpId Class
clas) Name
name Type
sel_ty IdInfo
info
  where
    tycon :: TyCon
tycon          = Class -> TyCon
classTyCon Class
clas
    sel_names :: [Name]
sel_names      = (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName (Class -> [Id]
classAllSelIds Class
clas)
    new_tycon :: Bool
new_tycon      = TyCon -> Bool
isNewTyCon TyCon
tycon
    [data_con :: DataCon
data_con]     = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
    tyvars :: [TyVarBinder]
tyvars         = DataCon -> [TyVarBinder]
dataConUserTyVarBinders DataCon
data_con
    n_ty_args :: Int
n_ty_args      = [TyVarBinder] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVarBinder]
tyvars
    arg_tys :: [Type]
arg_tys        = DataCon -> [Type]
dataConRepArgTys DataCon
data_con  -- Includes the dictionary superclasses
    val_index :: Int
val_index      = String -> Assoc Name Int -> Name -> Int
forall a b. Eq a => String -> Assoc a b -> a -> b
assoc "MkId.mkDictSelId" ([Name]
sel_names [Name] -> [Int] -> Assoc Name Int
forall a b. [a] -> [b] -> [(a, b)]
`zip` [0..]) Name
name

    sel_ty :: Type
sel_ty = [TyVarBinder] -> Type -> Type
mkForAllTys [TyVarBinder]
tyvars (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
             Type -> Type -> Type
mkFunTy (Class -> [Type] -> Type
mkClassPred Class
clas ([Id] -> [Type]
mkTyVarTys ([TyVarBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyVarBinder]
tyvars))) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
             [Type] -> Int -> Type
forall a. Outputable a => [a] -> Int -> a
getNth [Type]
arg_tys Int
val_index

    base_info :: IdInfo
base_info = IdInfo
noCafIdInfo
                IdInfo -> Int -> IdInfo
`setArityInfo`          1
                IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo`     StrictSig
strict_sig
                IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
sel_ty

    info :: IdInfo
info | Bool
new_tycon
         = IdInfo
base_info IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
                     IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`  Int -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity 1
                                           (Class -> Int -> CoreExpr
mkDictSelRhs Class
clas Int
val_index)
                   -- See Note [Single-method classes] in TcInstDcls
                   -- for why alwaysInlinePragma

         | Bool
otherwise
         = IdInfo
base_info IdInfo -> RuleInfo -> IdInfo
`setRuleInfo` [CoreRule] -> RuleInfo
mkRuleInfo [CoreRule
rule]
                   -- Add a magic BuiltinRule, but no unfolding
                   -- so that the rule is always available to fire.
                   -- See Note [ClassOp/DFun selection] in TcInstDcls

    -- This is the built-in rule that goes
    --      op (dfT d1 d2) --->  opT d1 d2
    rule :: CoreRule
rule = BuiltinRule :: RuleName -> Name -> Int -> RuleFun -> CoreRule
BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit "Class op " RuleName -> RuleName -> RuleName
`appendFS`
                                     OccName -> RuleName
occNameFS (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
name)
                       , ru_fn :: Name
ru_fn    = Name
name
                       , ru_nargs :: Int
ru_nargs = Int
n_ty_args Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
                       , ru_try :: RuleFun
ru_try   = Int -> Int -> RuleFun
dictSelRule Int
val_index Int
n_ty_args }

        -- The strictness signature is of the form U(AAAVAAAA) -> T
        -- where the V depends on which item we are selecting
        -- It's worth giving one, so that absence info etc is generated
        -- even if the selector isn't inlined

    strict_sig :: StrictSig
strict_sig = [Demand] -> DmdResult -> StrictSig
mkClosedStrictSig [Demand
arg_dmd] DmdResult
topRes
    arg_dmd :: Demand
arg_dmd | Bool
new_tycon = Demand
evalDmd
            | Bool
otherwise = CleanDemand -> Demand
mkManyUsedDmd (CleanDemand -> Demand) -> CleanDemand -> Demand
forall a b. (a -> b) -> a -> b
$
                          [Demand] -> CleanDemand
mkProdDmd [ if Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
sel_name then Demand
evalDmd else Demand
absDmd
                                    | Name
sel_name <- [Name]
sel_names ]

mkDictSelRhs :: Class
             -> Int         -- 0-indexed selector among (superclasses ++ methods)
             -> CoreExpr
mkDictSelRhs :: Class -> Int -> CoreExpr
mkDictSelRhs clas :: Class
clas val_index :: Int
val_index
  = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tyvars (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
dict_id CoreExpr
rhs_body)
  where
    tycon :: TyCon
tycon          = Class -> TyCon
classTyCon Class
clas
    new_tycon :: Bool
new_tycon      = TyCon -> Bool
isNewTyCon TyCon
tycon
    [data_con :: DataCon
data_con]     = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
    tyvars :: [Id]
tyvars         = DataCon -> [Id]
dataConUnivTyVars DataCon
data_con
    arg_tys :: [Type]
arg_tys        = DataCon -> [Type]
dataConRepArgTys DataCon
data_con  -- Includes the dictionary superclasses

    the_arg_id :: Id
the_arg_id     = [Id] -> Int -> Id
forall a. Outputable a => [a] -> Int -> a
getNth [Id]
arg_ids Int
val_index
    pred :: Type
pred           = Class -> [Type] -> Type
mkClassPred Class
clas ([Id] -> [Type]
mkTyVarTys [Id]
tyvars)
    dict_id :: Id
dict_id        = Int -> Type -> Id
mkTemplateLocal 1 Type
pred
    arg_ids :: [Id]
arg_ids        = Int -> [Type] -> [Id]
mkTemplateLocalsNum 2 [Type]
arg_tys

    rhs_body :: CoreExpr
rhs_body | Bool
new_tycon = TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody TyCon
tycon ([Id] -> [Type]
mkTyVarTys [Id]
tyvars)
                                                   (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
dict_id)
             | Bool
otherwise = CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
dict_id) Id
dict_id (Id -> Type
idType Id
the_arg_id)
                                [(DataCon -> AltCon
DataAlt DataCon
data_con, [Id]
arg_ids, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
the_arg_id)]
                                -- varToCoreExpr needed for equality superclass selectors
                                --   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }

dictSelRule :: Int -> Arity -> RuleFun
-- Tries to persuade the argument to look like a constructor
-- application, using exprIsConApp_maybe, and then selects
-- from it
--       sel_i t1..tk (D t1..tk op1 ... opm) = opi
--
dictSelRule :: Int -> Int -> RuleFun
dictSelRule val_index :: Int
val_index n_ty_args :: Int
n_ty_args _ id_unf :: InScopeEnv
id_unf _ args :: [CoreExpr]
args
  | (dict_arg :: CoreExpr
dict_arg : _) <- Int -> [CoreExpr] -> [CoreExpr]
forall a. Int -> [a] -> [a]
drop Int
n_ty_args [CoreExpr]
args
  , Just (_, _, con_args :: [CoreExpr]
con_args) <- InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
exprIsConApp_maybe InScopeEnv
id_unf CoreExpr
dict_arg
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just ([CoreExpr] -> Int -> CoreExpr
forall a. Outputable a => [a] -> Int -> a
getNth [CoreExpr]
con_args Int
val_index)
  | Bool
otherwise
  = Maybe CoreExpr
forall a. Maybe a
Nothing

{-
************************************************************************
*                                                                      *
        Data constructors
*                                                                      *
************************************************************************
-}

mkDataConWorkId :: Name -> DataCon -> Id
mkDataConWorkId :: Name -> DataCon -> Id
mkDataConWorkId wkr_name :: Name
wkr_name data_con :: DataCon
data_con
  | TyCon -> Bool
isNewTyCon TyCon
tycon
  = IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId (DataCon -> IdDetails
DataConWrapId DataCon
data_con) Name
wkr_name Type
wkr_ty IdInfo
nt_work_info
  | Bool
otherwise
  = IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId (DataCon -> IdDetails
DataConWorkId DataCon
data_con) Name
wkr_name Type
wkr_ty IdInfo
alg_wkr_info

  where
    tycon :: TyCon
tycon  = DataCon -> TyCon
dataConTyCon DataCon
data_con  -- The representation TyCon
    wkr_ty :: Type
wkr_ty = DataCon -> Type
dataConRepType DataCon
data_con

        ----------- Workers for data types --------------
    alg_wkr_info :: IdInfo
alg_wkr_info = IdInfo
noCafIdInfo
                   IdInfo -> Int -> IdInfo
`setArityInfo`          Int
wkr_arity
                   IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo`     StrictSig
wkr_sig
                   IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`      Unfolding
evaldUnfolding  -- Record that it's evaluated,
                                                           -- even if arity = 0
                   IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
wkr_ty
                     -- NB: unboxed tuples have workers, so we can't use
                     -- setNeverLevPoly

    wkr_arity :: Int
wkr_arity = DataCon -> Int
dataConRepArity DataCon
data_con
    wkr_sig :: StrictSig
wkr_sig   = [Demand] -> DmdResult -> StrictSig
mkClosedStrictSig (Int -> Demand -> [Demand]
forall a. Int -> a -> [a]
replicate Int
wkr_arity Demand
topDmd) (DataCon -> DmdResult
dataConCPR DataCon
data_con)
        --      Note [Data-con worker strictness]
        -- Notice that we do *not* say the worker Id is strict
        -- even if the data constructor is declared strict
        --      e.g.    data T = MkT !(Int,Int)
        -- Why?  Because the *wrapper* $WMkT is strict (and its unfolding has
        -- case expressions that do the evals) but the *worker* MkT itself is
        --  not. If we pretend it is strict then when we see
        --      case x of y -> MkT y
        -- the simplifier thinks that y is "sure to be evaluated" (because
        -- the worker MkT is strict) and drops the case.  No, the workerId
        -- MkT is not strict.
        --
        -- However, the worker does have StrictnessMarks.  When the simplifier
        -- sees a pattern
        --      case e of MkT x -> ...
        -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
        -- but that's fine... dataConRepStrictness comes from the data con
        -- not from the worker Id.

        ----------- Workers for newtypes --------------
    univ_tvs :: [Id]
univ_tvs = DataCon -> [Id]
dataConUnivTyVars DataCon
data_con
    arg_tys :: [Type]
arg_tys  = DataCon -> [Type]
dataConRepArgTys  DataCon
data_con  -- Should be same as dataConOrigArgTys
    nt_work_info :: IdInfo
nt_work_info = IdInfo
noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo
                  IdInfo -> Int -> IdInfo
`setArityInfo` 1      -- Arity 1
                  IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo`     InlinePragma
alwaysInlinePragma
                  IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`      Unfolding
newtype_unf
                  IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
wkr_ty
    id_arg1 :: Id
id_arg1      = Int -> Type -> Id
mkTemplateLocal 1 ([Type] -> Type
forall a. [a] -> a
head [Type]
arg_tys)
    res_ty_args :: [Type]
res_ty_args  = [Id] -> [Type]
mkTyCoVarTys [Id]
univ_tvs
    newtype_unf :: Unfolding
newtype_unf  = ASSERT2( isVanillaDataCon data_con &&
                            isSingleton arg_tys
                          , ppr data_con  )
                              -- Note [Newtype datacons]
                   CoreExpr -> Unfolding
mkCompulsoryUnfolding (CoreExpr -> Unfolding) -> CoreExpr -> Unfolding
forall a b. (a -> b) -> a -> b
$
                   [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
univ_tvs (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
id_arg1 (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                   TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapNewTypeBody TyCon
tycon [Type]
res_ty_args (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
id_arg1)

dataConCPR :: DataCon -> DmdResult
dataConCPR :: DataCon -> DmdResult
dataConCPR con :: DataCon
con
  | TyCon -> Bool
isDataTyCon TyCon
tycon     -- Real data types only; that is,
                          -- not unboxed tuples or newtypes
  , [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Id]
dataConExTyCoVars DataCon
con)  -- No existentials
  , Int
wkr_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
  , Int
wkr_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
mAX_CPR_SIZE
  = if Bool
is_prod then Int -> DmdResult
vanillaCprProdRes (DataCon -> Int
dataConRepArity DataCon
con)
               else Int -> DmdResult
cprSumRes (DataCon -> Int
dataConTag DataCon
con)
  | Bool
otherwise
  = DmdResult
topRes
  where
    is_prod :: Bool
is_prod   = TyCon -> Bool
isProductTyCon TyCon
tycon
    tycon :: TyCon
tycon     = DataCon -> TyCon
dataConTyCon DataCon
con
    wkr_arity :: Int
wkr_arity = DataCon -> Int
dataConRepArity DataCon
con

    mAX_CPR_SIZE :: Arity
    mAX_CPR_SIZE :: Int
mAX_CPR_SIZE = 10
    -- We do not treat very big tuples as CPR-ish:
    --      a) for a start we get into trouble because there aren't
    --         "enough" unboxed tuple types (a tiresome restriction,
    --         but hard to fix),
    --      b) more importantly, big unboxed tuples get returned mainly
    --         on the stack, and are often then allocated in the heap
    --         by the caller.  So doing CPR for them may in fact make
    --         things worse.

{-
-------------------------------------------------
--         Data constructor representation
--
-- This is where we decide how to wrap/unwrap the
-- constructor fields
--
--------------------------------------------------
-}

type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)
  -- Unbox: bind rep vars by decomposing src var

data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr))
  -- Box:   build src arg using these rep vars

-- | Data Constructor Boxer
newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
                       -- Bind these src-level vars, returning the
                       -- rep-level vars to bind in the pattern

{-
Note [Inline partially-applied constructor wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

We allow the wrapper to inline when partially applied to avoid
boxing values unnecessarily. For example, consider

   data Foo a = Foo !Int a

   instance Traversable Foo where
     traverse f (Foo i a) = Foo i <$> f a

This desugars to

   traverse f foo = case foo of
        Foo i# a -> let i = I# i#
                    in map ($WFoo i) (f a)

If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`.
But if we inline the wrapper, we get

   map (\a. case i of I# i# a -> Foo i# a) (f a)

and now case-of-known-constructor eliminates the redundant allocation.
-}

mkDataConRep :: DynFlags
             -> FamInstEnvs
             -> Name
             -> Maybe [HsImplBang]
                -- See Note [Bangs on imported data constructors]
             -> DataCon
             -> UniqSM DataConRep
mkDataConRep :: DynFlags
-> FamInstEnvs
-> Name
-> Maybe [HsImplBang]
-> DataCon
-> UniqSM DataConRep
mkDataConRep dflags :: DynFlags
dflags fam_envs :: FamInstEnvs
fam_envs wrap_name :: Name
wrap_name mb_bangs :: Maybe [HsImplBang]
mb_bangs data_con :: DataCon
data_con
  | Bool -> Bool
not Bool
wrapper_reqd
  = DataConRep -> UniqSM DataConRep
forall (m :: * -> *) a. Monad m => a -> m a
return DataConRep
NoDataConRep

  | Bool
otherwise
  = do { [Id]
wrap_args <- (Type -> UniqSM Id) -> [Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> UniqSM Id
newLocal [Type]
wrap_arg_tys
       ; CoreExpr
wrap_body <- [(Id, Unboxer)] -> CoreExpr -> UniqSM CoreExpr
mk_rep_app ([Id]
wrap_args [Id] -> [Unboxer] -> [(Id, Unboxer)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [EqSpec] -> [Unboxer] -> [Unboxer]
forall b a. [b] -> [a] -> [a]
dropList [EqSpec]
eq_spec [Unboxer]
unboxers)
                                 CoreExpr
forall b. Expr b
initial_wrap_app

       ; let wrap_id :: Id
wrap_id = IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId (DataCon -> IdDetails
DataConWrapId DataCon
data_con) Name
wrap_name Type
wrap_ty IdInfo
wrap_info
             wrap_info :: IdInfo
wrap_info = IdInfo
noCafIdInfo
                         IdInfo -> Int -> IdInfo
`setArityInfo`         Int
wrap_arity
                             -- It's important to specify the arity, so that partial
                             -- applications are treated as values
                         IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo`    InlinePragma
wrap_prag
                         IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`     Unfolding
wrap_unf
                         IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo`    StrictSig
wrap_sig
                             -- We need to get the CAF info right here because TidyPgm
                             -- does not tidy the IdInfo of implicit bindings (like the wrapper)
                             -- so it not make sure that the CAF info is sane
                         HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly`      Type
wrap_ty

             wrap_sig :: StrictSig
wrap_sig = [Demand] -> DmdResult -> StrictSig
mkClosedStrictSig [Demand]
wrap_arg_dmds (DataCon -> DmdResult
dataConCPR DataCon
data_con)

             wrap_arg_dmds :: [Demand]
wrap_arg_dmds =
               Int -> Demand -> [Demand]
forall a. Int -> a -> [a]
replicate ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
theta) Demand
topDmd [Demand] -> [Demand] -> [Demand]
forall a. [a] -> [a] -> [a]
++ (HsImplBang -> Demand) -> [HsImplBang] -> [Demand]
forall a b. (a -> b) -> [a] -> [b]
map HsImplBang -> Demand
mk_dmd [HsImplBang]
arg_ibangs
               -- Don't forget the dictionary arguments when building
               -- the strictness signature (#14290).

             mk_dmd :: HsImplBang -> Demand
mk_dmd str :: HsImplBang
str | HsImplBang -> Bool
isBanged HsImplBang
str = Demand
evalDmd
                        | Bool
otherwise           = Demand
topDmd

             wrap_prag :: InlinePragma
wrap_prag = InlinePragma
alwaysInlinePragma InlinePragma -> Activation -> InlinePragma
`setInlinePragmaActivation`
                         Activation
activeAfterInitial
                         -- See Note [Activation for data constructor wrappers]

             -- The wrapper will usually be inlined (see wrap_unf), so its
             -- strictness and CPR info is usually irrelevant. But this is
             -- not always the case; GHC may choose not to inline it. In
             -- particular, the wrapper constructor is not inlined inside
             -- an INLINE rhs or when it is not applied to any arguments.
             -- See Note [Inline partially-applied constructor wrappers]
             -- Passing Nothing here allows the wrapper to inline when
             -- unsaturated.
             wrap_unf :: Unfolding
wrap_unf = CoreExpr -> Unfolding
mkInlineUnfolding CoreExpr
wrap_rhs
             wrap_rhs :: CoreExpr
wrap_rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
wrap_tvs (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                        [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
wrap_args (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                        TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody TyCon
tycon [Type]
res_ty_args (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                        CoreExpr
wrap_body

       ; DataConRep -> UniqSM DataConRep
forall (m :: * -> *) a. Monad m => a -> m a
return (DCR :: Id
-> DataConBoxer
-> [Type]
-> [StrictnessMark]
-> [HsImplBang]
-> DataConRep
DCR { dcr_wrap_id :: Id
dcr_wrap_id = Id
wrap_id
                     , dcr_boxer :: DataConBoxer
dcr_boxer   = [Boxer] -> DataConBoxer
mk_boxer [Boxer]
boxers
                     , dcr_arg_tys :: [Type]
dcr_arg_tys = [Type]
rep_tys
                     , dcr_stricts :: [StrictnessMark]
dcr_stricts = [StrictnessMark]
rep_strs
                       -- For newtypes, dcr_bangs is always [HsLazy].
                       -- See Note [HsImplBangs for newtypes].
                     , dcr_bangs :: [HsImplBang]
dcr_bangs   = [HsImplBang]
arg_ibangs }) }

  where
    (univ_tvs :: [Id]
univ_tvs, ex_tvs :: [Id]
ex_tvs, eq_spec :: [EqSpec]
eq_spec, theta :: [Type]
theta, orig_arg_tys :: [Type]
orig_arg_tys, _orig_res_ty :: Type
_orig_res_ty)
      = DataCon -> ([Id], [Id], [EqSpec], [Type], [Type], Type)
dataConFullSig DataCon
data_con
    wrap_tvs :: [Id]
wrap_tvs     = DataCon -> [Id]
dataConUserTyVars DataCon
data_con
    res_ty_args :: [Type]
res_ty_args  = TCvSubst -> [Id] -> [Type]
substTyVars ([(Id, Type)] -> TCvSubst
mkTvSubstPrs ((EqSpec -> (Id, Type)) -> [EqSpec] -> [(Id, Type)]
forall a b. (a -> b) -> [a] -> [b]
map EqSpec -> (Id, Type)
eqSpecPair [EqSpec]
eq_spec)) [Id]
univ_tvs

    tycon :: TyCon
tycon        = DataCon -> TyCon
dataConTyCon DataCon
data_con       -- The representation TyCon (not family)
    wrap_ty :: Type
wrap_ty      = DataCon -> Type
dataConUserType DataCon
data_con
    ev_tys :: [Type]
ev_tys       = [EqSpec] -> [Type]
eqSpecPreds [EqSpec]
eq_spec [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
theta
    all_arg_tys :: [Type]
all_arg_tys  = [Type]
ev_tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
orig_arg_tys
    ev_ibangs :: [HsImplBang]
ev_ibangs    = (Type -> HsImplBang) -> [Type] -> [HsImplBang]
forall a b. (a -> b) -> [a] -> [b]
map (HsImplBang -> Type -> HsImplBang
forall a b. a -> b -> a
const HsImplBang
HsLazy) [Type]
ev_tys
    orig_bangs :: [HsSrcBang]
orig_bangs   = DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
data_con

    wrap_arg_tys :: [Type]
wrap_arg_tys = [Type]
theta [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
orig_arg_tys
    wrap_arity :: Int
wrap_arity   = (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isCoVar [Id]
ex_tvs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
wrap_arg_tys
             -- The wrap_args are the arguments *other than* the eq_spec
             -- Because we are going to apply the eq_spec args manually in the
             -- wrapper

    new_tycon :: Bool
new_tycon = TyCon -> Bool
isNewTyCon TyCon
tycon
    arg_ibangs :: [HsImplBang]
arg_ibangs
      | Bool
new_tycon
      = ASSERT( isSingleton orig_arg_tys )
        [HsImplBang
HsLazy] -- See Note [HsImplBangs for newtypes]
      | Bool
otherwise
      = case Maybe [HsImplBang]
mb_bangs of
          Nothing    -> (Type -> HsSrcBang -> HsImplBang)
-> [Type] -> [HsSrcBang] -> [HsImplBang]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (DynFlags -> FamInstEnvs -> Type -> HsSrcBang -> HsImplBang
dataConSrcToImplBang DynFlags
dflags FamInstEnvs
fam_envs)
                                [Type]
orig_arg_tys [HsSrcBang]
orig_bangs
          Just bangs :: [HsImplBang]
bangs -> [HsImplBang]
bangs

    (rep_tys_w_strs :: [[(Type, StrictnessMark)]]
rep_tys_w_strs, wrappers :: [(Unboxer, Boxer)]
wrappers)
      = [([(Type, StrictnessMark)], (Unboxer, Boxer))]
-> ([[(Type, StrictnessMark)]], [(Unboxer, Boxer)])
forall a b. [(a, b)] -> ([a], [b])
unzip ((Type
 -> HsImplBang -> ([(Type, StrictnessMark)], (Unboxer, Boxer)))
-> [Type]
-> [HsImplBang]
-> [([(Type, StrictnessMark)], (Unboxer, Boxer))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> HsImplBang -> ([(Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgRep [Type]
all_arg_tys ([HsImplBang]
ev_ibangs [HsImplBang] -> [HsImplBang] -> [HsImplBang]
forall a. [a] -> [a] -> [a]
++ [HsImplBang]
arg_ibangs))

    (unboxers :: [Unboxer]
unboxers, boxers :: [Boxer]
boxers) = [(Unboxer, Boxer)] -> ([Unboxer], [Boxer])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Unboxer, Boxer)]
wrappers
    (rep_tys :: [Type]
rep_tys, rep_strs :: [StrictnessMark]
rep_strs) = [(Type, StrictnessMark)] -> ([Type], [StrictnessMark])
forall a b. [(a, b)] -> ([a], [b])
unzip ([[(Type, StrictnessMark)]] -> [(Type, StrictnessMark)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Type, StrictnessMark)]]
rep_tys_w_strs)

    wrapper_reqd :: Bool
wrapper_reqd =
        (Bool -> Bool
not Bool
new_tycon
                     -- (Most) newtypes have only a worker, with the exception
                     -- of some newtypes written with GADT syntax. See below.
         Bool -> Bool -> Bool
&& ((HsImplBang -> Bool) -> [HsImplBang] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsImplBang -> Bool
isBanged ([HsImplBang]
ev_ibangs [HsImplBang] -> [HsImplBang] -> [HsImplBang]
forall a. [a] -> [a] -> [a]
++ [HsImplBang]
arg_ibangs)
                     -- Some forcing/unboxing (includes eq_spec)
             Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [EqSpec] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EqSpec]
eq_spec))) -- GADT
      Bool -> Bool -> Bool
|| TyCon -> Bool
isFamInstTyCon TyCon
tycon -- Cast result
      Bool -> Bool -> Bool
|| DataCon -> Bool
dataConUserTyVarsArePermuted DataCon
data_con
                     -- If the data type was written with GADT syntax and
                     -- orders the type variables differently from what the
                     -- worker expects, it needs a data con wrapper to reorder
                     -- the type variables.
                     -- See Note [Data con wrappers and GADT syntax].

    initial_wrap_app :: Expr b
initial_wrap_app = Id -> Expr b
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
data_con)
                       Expr b -> [Type] -> Expr b
forall b. Expr b -> [Type] -> Expr b
`mkTyApps`  [Type]
res_ty_args
                       Expr b -> [Id] -> Expr b
forall b. Expr b -> [Id] -> Expr b
`mkVarApps` [Id]
ex_tvs
                       Expr b -> [Coercion] -> Expr b
forall b. Expr b -> [Coercion] -> Expr b
`mkCoApps`  (EqSpec -> Coercion) -> [EqSpec] -> [Coercion]
forall a b. (a -> b) -> [a] -> [b]
map (Role -> Type -> Coercion
mkReflCo Role
Nominal (Type -> Coercion) -> (EqSpec -> Type) -> EqSpec -> Coercion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EqSpec -> Type
eqSpecType) [EqSpec]
eq_spec

    mk_boxer :: [Boxer] -> DataConBoxer
    mk_boxer :: [Boxer] -> DataConBoxer
mk_boxer boxers :: [Boxer]
boxers = ([Type] -> [Id] -> UniqSM ([Id], [CoreBind])) -> DataConBoxer
DCB (\ ty_args :: [Type]
ty_args src_vars :: [Id]
src_vars ->
                      do { let (ex_vars :: [Id]
ex_vars, term_vars :: [Id]
term_vars) = [Id] -> [Id] -> ([Id], [Id])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [Id]
ex_tvs [Id]
src_vars
                               subst1 :: TCvSubst
subst1 = [Id] -> [Type] -> TCvSubst
HasDebugCallStack => [Id] -> [Type] -> TCvSubst
zipTvSubst [Id]
univ_tvs [Type]
ty_args
                               subst2 :: TCvSubst
subst2 = TCvSubst -> [Id] -> [Type] -> TCvSubst
extendTCvSubstList TCvSubst
subst1 [Id]
ex_tvs
                                                           ([Id] -> [Type]
mkTyCoVarTys [Id]
ex_vars)
                         ; (rep_ids :: [Id]
rep_ids, binds :: [CoreBind]
binds) <- TCvSubst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
go TCvSubst
subst2 [Boxer]
boxers [Id]
term_vars
                         ; ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ex_vars [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
rep_ids, [CoreBind]
binds) } )

    go :: TCvSubst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
go _ [] src_vars :: [Id]
src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], [])
    go subst :: TCvSubst
subst (UnitBox : boxers :: [Boxer]
boxers) (src_var :: Id
src_var : src_vars :: [Id]
src_vars)
      = do { (rep_ids2 :: [Id]
rep_ids2, binds :: [CoreBind]
binds) <- TCvSubst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
go TCvSubst
subst [Boxer]
boxers [Id]
src_vars
           ; ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
src_var Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
rep_ids2, [CoreBind]
binds) }
    go subst :: TCvSubst
subst (Boxer boxer :: TCvSubst -> UniqSM ([Id], CoreExpr)
boxer : boxers :: [Boxer]
boxers) (src_var :: Id
src_var : src_vars :: [Id]
src_vars)
      = do { (rep_ids1 :: [Id]
rep_ids1, arg :: CoreExpr
arg)  <- TCvSubst -> UniqSM ([Id], CoreExpr)
boxer TCvSubst
subst
           ; (rep_ids2 :: [Id]
rep_ids2, binds :: [CoreBind]
binds) <- TCvSubst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
go TCvSubst
subst [Boxer]
boxers [Id]
src_vars
           ; ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids1 [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
rep_ids2, Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
src_var CoreExpr
arg CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: [CoreBind]
binds) }
    go _ (_:_) [] = String -> SDoc -> UniqSM ([Id], [CoreBind])
forall a. HasCallStack => String -> SDoc -> a
pprPanic "mk_boxer" (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
data_con)

    mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr
    mk_rep_app :: [(Id, Unboxer)] -> CoreExpr -> UniqSM CoreExpr
mk_rep_app [] con_app :: CoreExpr
con_app
      = CoreExpr -> UniqSM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
con_app
    mk_rep_app ((wrap_arg :: Id
wrap_arg, unboxer :: Unboxer
unboxer) : prs :: [(Id, Unboxer)]
prs) con_app :: CoreExpr
con_app
      = do { (rep_ids :: [Id]
rep_ids, unbox_fn :: CoreExpr -> CoreExpr
unbox_fn) <- Unboxer
unboxer Id
wrap_arg
           ; CoreExpr
expr <- [(Id, Unboxer)] -> CoreExpr -> UniqSM CoreExpr
mk_rep_app [(Id, Unboxer)]
prs (CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps CoreExpr
con_app [Id]
rep_ids)
           ; CoreExpr -> UniqSM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoreExpr
unbox_fn CoreExpr
expr) }

{- Note [Activation for data constructor wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Activation on a data constructor wrapper allows it to inline in
Phase 2 and later (1, 0).  But not in the InitialPhase.  That gives
rewrite rules a chance to fire (in the InitialPhase) if they mention
a data constructor on the left
   RULE "foo"  f (K a b) = ...
Since the LHS of rules are simplified with InitialPhase, we won't
inline the wrapper on the LHS either.

People have asked for this before, but now that even the InitialPhase
does some inlining, it has become important.


Note [Bangs on imported data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs
from imported modules.

- Nothing <=> use HsSrcBangs
- Just bangs <=> use HsImplBangs

For imported types we can't work it all out from the HsSrcBangs,
because we want to be very sure to follow what the original module
(where the data type was declared) decided, and that depends on what
flags were enabled when it was compiled. So we record the decisions in
the interface file.

The HsImplBangs passed are in 1-1 correspondence with the
dataConOrigArgTys of the DataCon.

Note [Data con wrappers and unlifted types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   data T = MkT !Int#

We certainly do not want to make a wrapper
   $WMkT x = case x of y { DEFAULT -> MkT y }

For a start, it's still to generate a no-op.  But worse, since wrappers
are currently injected at TidyCore, we don't even optimise it away!
So the stupid case expression stays there.  This actually happened for
the Integer data type (see Trac #1600 comment:66)!

Note [Data con wrappers and GADT syntax]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider these two very similar data types:

  data T1 a b = MkT1 b

  data T2 a b where
    MkT2 :: forall b a. b -> T2 a b

Despite their similar appearance, T2 will have a data con wrapper but T1 will
not. What sets them apart? The types of their constructors, which are:

  MkT1 :: forall a b. b -> T1 a b
  MkT2 :: forall b a. b -> T2 a b

MkT2's use of GADT syntax allows it to permute the order in which `a` and `b`
would normally appear. See Note [DataCon user type variable binders] in DataCon
for further discussion on this topic.

The worker data cons for T1 and T2, however, both have types such that `a` is
expected to come before `b` as arguments. Because MkT2 permutes this order, it
needs a data con wrapper to swizzle around the type variables to be in the
order the worker expects.

A somewhat surprising consequence of this is that *newtypes* can have data con
wrappers! After all, a newtype can also be written with GADT syntax:

  newtype T3 a b where
    MkT3 :: forall b a. b -> T3 a b

Again, this needs a wrapper data con to reorder the type variables. It does
mean that this newtype constructor requires another level of indirection when
being called, but the inliner should make swift work of that.

Note [HsImplBangs for newtypes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Most of the time, we use the dataConSrctoImplBang function to decide what
strictness/unpackedness to use for the fields of a data type constructor. But
there is an exception to this rule: newtype constructors. You might not think
that newtypes would pose a challenge, since newtypes are seemingly forbidden
from having strictness annotations in the first place. But consider this
(from Trac #16141):

  {-# LANGUAGE StrictData #-}
  {-# OPTIONS_GHC -O #-}
  newtype T a b where
    MkT :: forall b a. Int -> T a b

Because StrictData (plus optimization) is enabled, invoking
dataConSrcToImplBang would sneak in and unpack the field of type Int to Int#!
This would be disastrous, since the wrapper for `MkT` uses a coercion involving
Int, not Int#.

Bottom line: dataConSrcToImplBang should never be invoked for newtypes. In the
case of a newtype constructor, we simply hardcode its dcr_bangs field to
[HsLazy].
-}

-------------------------
newLocal :: Type -> UniqSM Var
newLocal :: Type -> UniqSM Id
newLocal ty :: Type
ty = do { Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
                 ; Id -> UniqSM Id
forall (m :: * -> *) a. Monad m => a -> m a
return (RuleName -> Unique -> Type -> Id
mkSysLocalOrCoVar (String -> RuleName
fsLit "dt") Unique
uniq Type
ty) }

-- | Unpack/Strictness decisions from source module.
--
-- This function should only ever be invoked for data constructor fields, and
-- never on the field of a newtype constructor.
-- See @Note [HsImplBangs for newtypes]@.
dataConSrcToImplBang
   :: DynFlags
   -> FamInstEnvs
   -> Type
   -> HsSrcBang
   -> HsImplBang

dataConSrcToImplBang :: DynFlags -> FamInstEnvs -> Type -> HsSrcBang -> HsImplBang
dataConSrcToImplBang dflags :: DynFlags
dflags fam_envs :: FamInstEnvs
fam_envs arg_ty :: Type
arg_ty
                     (HsSrcBang ann :: SourceText
ann unpk :: SrcUnpackedness
unpk NoSrcStrict)
  | Extension -> DynFlags -> Bool
xopt Extension
LangExt.StrictData DynFlags
dflags -- StrictData => strict field
  = DynFlags -> FamInstEnvs -> Type -> HsSrcBang -> HsImplBang
dataConSrcToImplBang DynFlags
dflags FamInstEnvs
fam_envs Type
arg_ty
                  (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
ann SrcUnpackedness
unpk SrcStrictness
SrcStrict)
  | Bool
otherwise -- no StrictData => lazy field
  = HsImplBang
HsLazy

dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)
  = HsImplBang
HsLazy

dataConSrcToImplBang dflags :: DynFlags
dflags fam_envs :: FamInstEnvs
fam_envs arg_ty :: Type
arg_ty
                     (HsSrcBang _ unpk_prag :: SrcUnpackedness
unpk_prag SrcStrict)
  | HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
arg_ty
  = HsImplBang
HsLazy  -- For !Int#, say, use HsLazy
            -- See Note [Data con wrappers and unlifted types]

  | Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitInterfacePragmas DynFlags
dflags) -- Don't unpack if -fomit-iface-pragmas
          -- Don't unpack if we aren't optimising; rather arbitrarily,
          -- we use -fomit-iface-pragmas as the indication
  , let mb_co :: Maybe (Coercion, Type)
mb_co   = FamInstEnvs -> Type -> Maybe (Coercion, Type)
topNormaliseType_maybe FamInstEnvs
fam_envs Type
arg_ty
                     -- Unwrap type families and newtypes
        arg_ty' :: Type
arg_ty' = case Maybe (Coercion, Type)
mb_co of { Just (_,ty :: Type
ty) -> Type
ty; Nothing -> Type
arg_ty }
  , DynFlags -> FamInstEnvs -> Type -> Bool
isUnpackableType DynFlags
dflags FamInstEnvs
fam_envs Type
arg_ty'
  , (rep_tys :: [(Type, StrictnessMark)]
rep_tys, _) <- Type -> ([(Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack Type
arg_ty'
  , case SrcUnpackedness
unpk_prag of
      NoSrcUnpack ->
        GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_UnboxStrictFields DynFlags
dflags
            Bool -> Bool -> Bool
|| (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_UnboxSmallStrictFields DynFlags
dflags
                Bool -> Bool -> Bool
&& [(Type, StrictnessMark)]
rep_tys [(Type, StrictnessMark)] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtMost` 1) -- See Note [Unpack one-wide fields]
      srcUnpack :: SrcUnpackedness
srcUnpack -> SrcUnpackedness -> Bool
isSrcUnpacked SrcUnpackedness
srcUnpack
  = case Maybe (Coercion, Type)
mb_co of
      Nothing     -> Maybe Coercion -> HsImplBang
HsUnpack Maybe Coercion
forall a. Maybe a
Nothing
      Just (co :: Coercion
co,_) -> Maybe Coercion -> HsImplBang
HsUnpack (Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just Coercion
co)

  | Bool
otherwise -- Record the strict-but-no-unpack decision
  = HsImplBang
HsStrict


-- | Wrappers/Workers and representation following Unpack/Strictness
-- decisions
dataConArgRep
  :: Type
  -> HsImplBang
  -> ([(Type,StrictnessMark)] -- Rep types
     ,(Unboxer,Boxer))

dataConArgRep :: Type -> HsImplBang -> ([(Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgRep arg_ty :: Type
arg_ty HsLazy
  = ([(Type
arg_ty, StrictnessMark
NotMarkedStrict)], (Unboxer
unitUnboxer, Boxer
unitBoxer))

dataConArgRep arg_ty :: Type
arg_ty HsStrict
  = ([(Type
arg_ty, StrictnessMark
MarkedStrict)], (Unboxer
seqUnboxer, Boxer
unitBoxer))

dataConArgRep arg_ty :: Type
arg_ty (HsUnpack Nothing)
  | (rep_tys :: [(Type, StrictnessMark)]
rep_tys, wrappers :: (Unboxer, Boxer)
wrappers) <- Type -> ([(Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack Type
arg_ty
  = ([(Type, StrictnessMark)]
rep_tys, (Unboxer, Boxer)
wrappers)

dataConArgRep _ (HsUnpack (Just co :: Coercion
co))
  | let co_rep_ty :: Type
co_rep_ty = Pair Type -> Type
forall a. Pair a -> a
pSnd (Coercion -> Pair Type
coercionKind Coercion
co)
  , (rep_tys :: [(Type, StrictnessMark)]
rep_tys, wrappers :: (Unboxer, Boxer)
wrappers) <- Type -> ([(Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack Type
co_rep_ty
  = ([(Type, StrictnessMark)]
rep_tys, Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
wrapCo Coercion
co Type
co_rep_ty (Unboxer, Boxer)
wrappers)


-------------------------
wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
wrapCo co :: Coercion
co rep_ty :: Type
rep_ty (unbox_rep :: Unboxer
unbox_rep, box_rep :: Boxer
box_rep)  -- co :: arg_ty ~ rep_ty
  = (Unboxer
unboxer, Boxer
boxer)
  where
    unboxer :: Unboxer
unboxer arg_id :: Id
arg_id = do { Id
rep_id <- Type -> UniqSM Id
newLocal Type
rep_ty
                        ; (rep_ids :: [Id]
rep_ids, rep_fn :: CoreExpr -> CoreExpr
rep_fn) <- Unboxer
unbox_rep Id
rep_id
                        ; let co_bind :: CoreBind
co_bind = Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
rep_id (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
arg_id CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
`Cast` Coercion
co)
                        ; ([Id], CoreExpr -> CoreExpr) -> UniqSM ([Id], CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids, CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
co_bind (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
rep_fn) }
    boxer :: Boxer
boxer = (TCvSubst -> UniqSM ([Id], CoreExpr)) -> Boxer
Boxer ((TCvSubst -> UniqSM ([Id], CoreExpr)) -> Boxer)
-> (TCvSubst -> UniqSM ([Id], CoreExpr)) -> Boxer
forall a b. (a -> b) -> a -> b
$ \ subst :: TCvSubst
subst ->
            do { (rep_ids :: [Id]
rep_ids, rep_expr :: CoreExpr
rep_expr)
                    <- case Boxer
box_rep of
                         UnitBox -> do { Id
rep_id <- Type -> UniqSM Id
newLocal (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
TcType.substTy TCvSubst
subst Type
rep_ty)
                                       ; ([Id], CoreExpr) -> UniqSM ([Id], CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id
rep_id], Id -> CoreExpr
forall b. Id -> Expr b
Var Id
rep_id) }
                         Boxer boxer :: TCvSubst -> UniqSM ([Id], CoreExpr)
boxer -> TCvSubst -> UniqSM ([Id], CoreExpr)
boxer TCvSubst
subst
               ; let sco :: Coercion
sco = TCvSubst -> Coercion -> Coercion
substCoUnchecked TCvSubst
subst Coercion
co
               ; ([Id], CoreExpr) -> UniqSM ([Id], CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids, CoreExpr
rep_expr CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
`Cast` Coercion -> Coercion
mkSymCo Coercion
sco) }

------------------------
seqUnboxer :: Unboxer
seqUnboxer :: Unboxer
seqUnboxer v :: Id
v = ([Id], CoreExpr -> CoreExpr) -> UniqSM ([Id], CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id
v], \e :: CoreExpr
e -> CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
v) Id
v (CoreExpr -> Type
exprType CoreExpr
e) [(AltCon
DEFAULT, [], CoreExpr
e)])

unitUnboxer :: Unboxer
unitUnboxer :: Unboxer
unitUnboxer v :: Id
v = ([Id], CoreExpr -> CoreExpr) -> UniqSM ([Id], CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id
v], \e :: CoreExpr
e -> CoreExpr
e)

unitBoxer :: Boxer
unitBoxer :: Boxer
unitBoxer = Boxer
UnitBox

-------------------------
dataConArgUnpack
   :: Type
   ->  ( [(Type, StrictnessMark)]   -- Rep types
       , (Unboxer, Boxer) )

dataConArgUnpack :: Type -> ([(Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack arg_ty :: Type
arg_ty
  | Just (tc :: TyCon
tc, tc_args :: [Type]
tc_args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
arg_ty
  , Just con :: DataCon
con <- TyCon -> Maybe DataCon
tyConSingleAlgDataCon_maybe TyCon
tc
      -- NB: check for an *algebraic* data type
      -- A recursive newtype might mean that
      -- 'arg_ty' is a newtype
  , let rep_tys :: [Type]
rep_tys = DataCon -> [Type] -> [Type]
dataConInstArgTys DataCon
con [Type]
tc_args
  = ASSERT( null (dataConExTyCoVars con) )
      -- Note [Unpacking GADTs and existentials]
    ( [Type]
rep_tys [Type] -> [StrictnessMark] -> [(Type, StrictnessMark)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
con
    ,( \ arg_id :: Id
arg_id ->
       do { [Id]
rep_ids <- (Type -> UniqSM Id) -> [Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> UniqSM Id
newLocal [Type]
rep_tys
          ; let unbox_fn :: CoreExpr -> CoreExpr
unbox_fn body :: CoreExpr
body
                  = CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
arg_id) Id
arg_id (CoreExpr -> Type
exprType CoreExpr
body)
                         [(DataCon -> AltCon
DataAlt DataCon
con, [Id]
rep_ids, CoreExpr
body)]
          ; ([Id], CoreExpr -> CoreExpr) -> UniqSM ([Id], CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids, CoreExpr -> CoreExpr
unbox_fn) }
     , (TCvSubst -> UniqSM ([Id], CoreExpr)) -> Boxer
Boxer ((TCvSubst -> UniqSM ([Id], CoreExpr)) -> Boxer)
-> (TCvSubst -> UniqSM ([Id], CoreExpr)) -> Boxer
forall a b. (a -> b) -> a -> b
$ \ subst :: TCvSubst
subst ->
       do { [Id]
rep_ids <- (Type -> UniqSM Id) -> [Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> UniqSM Id
newLocal (Type -> UniqSM Id) -> (Type -> Type) -> Type -> UniqSM Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCvSubst -> Type -> Type
TcType.substTyUnchecked TCvSubst
subst) [Type]
rep_tys
          ; ([Id], CoreExpr) -> UniqSM ([Id], CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids, Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
con)
                             CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` (TCvSubst -> [Type] -> [Type]
substTysUnchecked TCvSubst
subst [Type]
tc_args)
                             CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
`mkVarApps` [Id]
rep_ids ) } ) )
  | Bool
otherwise
  = String -> SDoc -> ([(Type, StrictnessMark)], (Unboxer, Boxer))
forall a. HasCallStack => String -> SDoc -> a
pprPanic "dataConArgUnpack" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_ty)
    -- An interface file specified Unpacked, but we couldn't unpack it

isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool
-- True if we can unpack the UNPACK the argument type
-- See Note [Recursive unboxing]
-- We look "deeply" inside rather than relying on the DataCons
-- we encounter on the way, because otherwise we might well
-- end up relying on ourselves!
isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool
isUnpackableType dflags :: DynFlags
dflags fam_envs :: FamInstEnvs
fam_envs ty :: Type
ty
  | Just data_con :: DataCon
data_con <- Type -> Maybe DataCon
unpackable_type Type
ty
  = NameSet -> DataCon -> Bool
ok_con_args NameSet
emptyNameSet DataCon
data_con
  | Bool
otherwise
  = Bool
False
  where
    ok_con_args :: NameSet -> DataCon -> Bool
ok_con_args dcs :: NameSet
dcs con :: DataCon
con
       | Name
dc_name Name -> NameSet -> Bool
`elemNameSet` NameSet
dcs
       = Bool
False
       | Bool
otherwise
       = ((Type, HsSrcBang) -> Bool) -> [(Type, HsSrcBang)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (NameSet -> (Type, HsSrcBang) -> Bool
ok_arg NameSet
dcs')
             (DataCon -> [Type]
dataConOrigArgTys DataCon
con [Type] -> [HsSrcBang] -> [(Type, HsSrcBang)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
con)
          -- NB: dataConSrcBangs gives the *user* request;
          -- We'd get a black hole if we used dataConImplBangs
       where
         dc_name :: Name
dc_name = DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
con
         dcs' :: NameSet
dcs' = NameSet
dcs NameSet -> Name -> NameSet
`extendNameSet` Name
dc_name

    ok_arg :: NameSet -> (Type, HsSrcBang) -> Bool
ok_arg dcs :: NameSet
dcs (ty :: Type
ty, bang :: HsSrcBang
bang)
      = Bool -> Bool
not (HsSrcBang -> Bool
attempt_unpack HsSrcBang
bang) Bool -> Bool -> Bool
|| NameSet -> Type -> Bool
ok_ty NameSet
dcs Type
norm_ty
      where
        norm_ty :: Type
norm_ty = FamInstEnvs -> Type -> Type
topNormaliseType FamInstEnvs
fam_envs Type
ty

    ok_ty :: NameSet -> Type -> Bool
ok_ty dcs :: NameSet
dcs ty :: Type
ty
      | Just data_con :: DataCon
data_con <- Type -> Maybe DataCon
unpackable_type Type
ty
      = NameSet -> DataCon -> Bool
ok_con_args NameSet
dcs DataCon
data_con
      | Bool
otherwise
      = Bool
True        -- NB True here, in contrast to False at top level

    attempt_unpack :: HsSrcBang -> Bool
attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)
      = Extension -> DynFlags -> Bool
xopt Extension
LangExt.StrictData DynFlags
dflags
    attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)
      = Bool
True
    attempt_unpack (HsSrcBang _  NoSrcUnpack SrcStrict)
      = Bool
True  -- Be conservative
    attempt_unpack (HsSrcBang _  NoSrcUnpack NoSrcStrict)
      = Extension -> DynFlags -> Bool
xopt Extension
LangExt.StrictData DynFlags
dflags -- Be conservative
    attempt_unpack _ = Bool
False

    unpackable_type :: Type -> Maybe DataCon
    -- Works just on a single level
    unpackable_type :: Type -> Maybe DataCon
unpackable_type ty :: Type
ty
      | Just (tc :: TyCon
tc, _) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
      , Just data_con :: DataCon
data_con <- TyCon -> Maybe DataCon
tyConSingleAlgDataCon_maybe TyCon
tc
      , [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Id]
dataConExTyCoVars DataCon
data_con)
          -- See Note [Unpacking GADTs and existentials]
      = DataCon -> Maybe DataCon
forall a. a -> Maybe a
Just DataCon
data_con
      | Bool
otherwise
      = Maybe DataCon
forall a. Maybe a
Nothing

{-
Note [Unpacking GADTs and existentials]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There is nothing stopping us unpacking a data type with equality
components, like
  data Equal a b where
    Equal :: Equal a a

And it'd be fine to unpack a product type with existential components
too, but that would require a bit more plumbing, so currently we don't.

So for now we require: null (dataConExTyCoVars data_con)
See Trac #14978

Note [Unpack one-wide fields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The flag UnboxSmallStrictFields ensures that any field that can
(safely) be unboxed to a word-sized unboxed field, should be so unboxed.
For example:

    data A = A Int#
    newtype B = B A
    data C = C !B
    data D = D !C
    data E = E !()
    data F = F !D
    data G = G !F !F

All of these should have an Int# as their representation, except
G which should have two Int#s.

However

    data T = T !(S Int)
    data S = S !a

Here we can represent T with an Int#.

Note [Recursive unboxing]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  data R = MkR {-# UNPACK #-} !S Int
  data S = MkS {-# UNPACK #-} !Int
The representation arguments of MkR are the *representation* arguments
of S (plus Int); the rep args of MkS are Int#.  This is all fine.

But be careful not to try to unbox this!
        data T = MkT {-# UNPACK #-} !T Int
Because then we'd get an infinite number of arguments.

Here is a more complicated case:
        data S = MkS {-# UNPACK #-} !T Int
        data T = MkT {-# UNPACK #-} !S Int
Each of S and T must decide independently whether to unpack
and they had better not both say yes. So they must both say no.

Also behave conservatively when there is no UNPACK pragma
        data T = MkS !T Int
with -funbox-strict-fields or -funbox-small-strict-fields
we need to behave as if there was an UNPACK pragma there.

But it's the *argument* type that matters. This is fine:
        data S = MkS S !Int
because Int is non-recursive.

************************************************************************
*                                                                      *
        Wrapping and unwrapping newtypes and type families
*                                                                      *
************************************************************************
-}

wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-- The wrapper for the data constructor for a newtype looks like this:
--      newtype T a = MkT (a,Int)
--      MkT :: forall a. (a,Int) -> T a
--      MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a)
-- where CoT is the coercion TyCon associated with the newtype
--
-- The call (wrapNewTypeBody T [a] e) returns the
-- body of the wrapper, namely
--      e `cast` (CoT [a])
--
-- If a coercion constructor is provided in the newtype, then we use
-- it, otherwise the wrap/unwrap are both no-ops

wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapNewTypeBody tycon :: TyCon
tycon args :: [Type]
args result_expr :: CoreExpr
result_expr
  = ASSERT( isNewTyCon tycon )
    CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
result_expr (Coercion -> Coercion
mkSymCo Coercion
co)
  where
    co :: Coercion
co = Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
tycon) [Type]
args []

-- When unwrapping, we do *not* apply any family coercion, because this will
-- be done via a CoPat by the type checker.  We have to do it this way as
-- computing the right type arguments for the coercion requires more than just
-- a spliting operation (cf, TcPat.tcConPat).

unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon :: TyCon
tycon args :: [Type]
args result_expr :: CoreExpr
result_expr
  = ASSERT( isNewTyCon tycon )
    CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
result_expr (Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
tycon) [Type]
args [])

-- If the type constructor is a representation type of a data instance, wrap
-- the expression into a cast adjusting the expression type, which is an
-- instance of the representation type, to the corresponding instance of the
-- family instance type.
-- See Note [Wrappers for data instance tycons]
wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody tycon :: TyCon
tycon args :: [Type]
args body :: CoreExpr
body
  | Just co_con :: CoAxiom Unbranched
co_con <- TyCon -> Maybe (CoAxiom Unbranched)
tyConFamilyCoercion_maybe TyCon
tycon
  = CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
body (Coercion -> Coercion
mkSymCo (Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational CoAxiom Unbranched
co_con [Type]
args []))
  | Bool
otherwise
  = CoreExpr
body

{-
************************************************************************
*                                                                      *
\subsection{Primitive operations}
*                                                                      *
************************************************************************
-}

mkPrimOpId :: PrimOp -> Id
mkPrimOpId :: PrimOp -> Id
mkPrimOpId prim_op :: PrimOp
prim_op
  = Id
id
  where
    (tyvars :: [Id]
tyvars,arg_tys :: [Type]
arg_tys,res_ty :: Type
res_ty, arity :: Int
arity, strict_sig :: StrictSig
strict_sig) = PrimOp -> ([Id], [Type], Type, Int, StrictSig)
primOpSig PrimOp
prim_op
    ty :: Type
ty   = [Id] -> Type -> Type
mkSpecForAllTys [Id]
tyvars ([Type] -> Type -> Type
mkFunTys [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))
                         (Id -> TyThing
AnId Id
id) BuiltInSyntax
UserSyntax
    id :: Id
id   = IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId (PrimOp -> IdDetails
PrimOpId PrimOp
prim_op) Name
name Type
ty IdInfo
info

    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 -> StrictSig -> IdInfo
`setStrictnessInfo`     StrictSig
strict_sig
           IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo`     InlinePragma
neverInlinePragma
           IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
res_ty
               -- 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 Trac #7287

-- For each ccall we manufacture a separate CCallOpId, giving it
-- a fresh unique, a type that is correct for this particular ccall,
-- and a CCall structure that gives the correct details about calling
-- convention etc.
--
-- The *name* of this Id is a local name whose OccName gives the full
-- details of the ccall, type and all.  This means that the interface
-- file reader can reconstruct a suitable Id

mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
mkFCallId dflags :: DynFlags
dflags uniq :: Unique
uniq fcall :: ForeignCall
fcall ty :: Type
ty
  = ASSERT( noFreeVarsOfType ty )
    -- A CCallOpId should have no free type variables;
    -- when doing substitutions won't substitute over it
    IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId (ForeignCall -> IdDetails
FCallId ForeignCall
fcall) Name
name Type
ty IdInfo
info
  where
    occ_str :: String
occ_str = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> SDoc
braces (ForeignCall -> SDoc
forall a. Outputable a => a -> SDoc
ppr ForeignCall
fcall SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty))
    -- The "occurrence name" of a ccall is the full info about the
    -- ccall; it is encoded, but may have embedded spaces etc!

    name :: Name
name = Unique -> String -> Name
mkFCallName Unique
uniq String
occ_str

    info :: IdInfo
info = IdInfo
noCafIdInfo
           IdInfo -> Int -> IdInfo
`setArityInfo`          Int
arity
           IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo`     StrictSig
strict_sig
           IdInfo -> Type -> IdInfo
`setLevityInfoWithType` Type
ty

    (bndrs :: [TyBinder]
bndrs, _) = Type -> ([TyBinder], Type)
tcSplitPiTys Type
ty
    arity :: Int
arity      = (TyBinder -> Bool) -> [TyBinder] -> Int
forall a. (a -> Bool) -> [a] -> Int
count TyBinder -> Bool
isAnonTyCoBinder [TyBinder]
bndrs
    strict_sig :: StrictSig
strict_sig = [Demand] -> DmdResult -> StrictSig
mkClosedStrictSig (Int -> Demand -> [Demand]
forall a. Int -> a -> [a]
replicate Int
arity Demand
topDmd) DmdResult
topRes
    -- the call does not claim to be strict in its arguments, since they
    -- may be lifted (foreign import prim) and the called code doesn't
    -- necessarily force them. See Trac #11076.
{-
************************************************************************
*                                                                      *
\subsection{DictFuns and default methods}
*                                                                      *
************************************************************************

Note [Dict funs and default methods]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dict funs and default methods are *not* ImplicitIds.  Their definition
involves user-written code, so we can't figure out their strictness etc
based on fixed info, as we can for constructors and record selectors (say).

NB: See also Note [Exported LocalIds] in Id
-}

mkDictFunId :: Name      -- Name to use for the dict fun;
            -> [TyVar]
            -> ThetaType
            -> Class
            -> [Type]
            -> Id
-- Implements the DFun Superclass Invariant (see TcInstDcls)
-- See Note [Dict funs and default methods]

mkDictFunId :: Name -> [Id] -> [Type] -> Class -> [Type] -> Id
mkDictFunId dfun_name :: Name
dfun_name tvs :: [Id]
tvs theta :: [Type]
theta clas :: Class
clas tys :: [Type]
tys
  = IdDetails -> Name -> Type -> Id
mkExportedLocalId (Bool -> IdDetails
DFunId Bool
is_nt)
                      Name
dfun_name
                      Type
dfun_ty
  where
    is_nt :: Bool
is_nt = TyCon -> Bool
isNewTyCon (Class -> TyCon
classTyCon Class
clas)
    dfun_ty :: Type
dfun_ty = [Id] -> [Type] -> Class -> [Type] -> Type
mkDictFunTy [Id]
tvs [Type]
theta Class
clas [Type]
tys

mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type
mkDictFunTy :: [Id] -> [Type] -> Class -> [Type] -> Type
mkDictFunTy tvs :: [Id]
tvs theta :: [Type]
theta clas :: Class
clas tys :: [Type]
tys
 = [Id] -> [Type] -> Type -> Type
mkSpecSigmaTy [Id]
tvs [Type]
theta (Class -> [Type] -> Type
mkClassPred Class
clas [Type]
tys)

{-
************************************************************************
*                                                                      *
\subsection{Un-definable}
*                                                                      *
************************************************************************

These Ids can't be defined in Haskell.  They could be defined in
unfoldings in the wired-in GHC.Prim interface file, but we'd have to
ensure that they were definitely, definitely inlined, because there is
no curried identifier for them.  That's what mkCompulsoryUnfolding
does.  If we had a way to get a compulsory unfolding from an interface
file, we could do that, but we don't right now.

unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
just gets expanded into a type coercion wherever it occurs.  Hence we
add it as a built-in Id with an unfolding here.

The type variables we use here are "open" type variables: this means
they can unify with both unlifted and lifted types.  Hence we provide
another gun with which to shoot yourself in the foot.
-}

unsafeCoerceName, nullAddrName, seqName,
   realWorldName, voidPrimIdName, coercionTokenName,
   magicDictName, coerceName, proxyName :: Name
unsafeCoerceName :: Name
unsafeCoerceName  = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit "unsafeCoerce#")  Unique
unsafeCoerceIdKey  Id
unsafeCoerceId
nullAddrName :: Name
nullAddrName      = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit "nullAddr#")      Unique
nullAddrIdKey      Id
nullAddrId
seqName :: Name
seqName           = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit "seq")            Unique
seqIdKey           Id
seqId
realWorldName :: Name
realWorldName     = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit "realWorld#")     Unique
realWorldPrimIdKey Id
realWorldPrimId
voidPrimIdName :: Name
voidPrimIdName    = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit "void#")          Unique
voidPrimIdKey      Id
voidPrimId
coercionTokenName :: Name
coercionTokenName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit "coercionToken#") Unique
coercionTokenIdKey Id
coercionTokenId
magicDictName :: Name
magicDictName     = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit "magicDict")      Unique
magicDictKey       Id
magicDictId
coerceName :: Name
coerceName        = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit "coerce")         Unique
coerceKey          Id
coerceId
proxyName :: Name
proxyName         = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit "proxy#")         Unique
proxyHashKey       Id
proxyHashId

lazyIdName, oneShotName, noinlineIdName :: Name
lazyIdName :: Name
lazyIdName        = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_MAGIC (String -> RuleName
fsLit "lazy")           Unique
lazyIdKey          Id
lazyId
oneShotName :: Name
oneShotName       = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_MAGIC (String -> RuleName
fsLit "oneShot")        Unique
oneShotKey         Id
oneShotId
noinlineIdName :: Name
noinlineIdName    = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_MAGIC (String -> RuleName
fsLit "noinline")       Unique
noinlineIdKey      Id
noinlineId

------------------------------------------------
proxyHashId :: Id
proxyHashId :: Id
proxyHashId
  = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
proxyName Type
ty
       (IdInfo
noCafIdInfo IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
evaldUnfolding -- Note [evaldUnfoldings]
                    HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly`  Type
ty )
  where
    -- proxy# :: forall k (a:k). Proxy# k a
    bndrs :: [Id]
bndrs   = [Type] -> ([Type] -> [Type]) -> [Id]
mkTemplateKiTyVars [Type
liftedTypeKind] [Type] -> [Type]
forall a. a -> a
id
    [k :: Type
k,t :: Type
t]   = [Id] -> [Type]
mkTyVarTys [Id]
bndrs
    ty :: Type
ty      = [Id] -> Type -> Type
mkSpecForAllTys [Id]
bndrs (Type -> Type -> Type
mkProxyPrimTy Type
k Type
t)

------------------------------------------------
unsafeCoerceId :: Id
unsafeCoerceId :: Id
unsafeCoerceId
  = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
unsafeCoerceName Type
ty IdInfo
info
  where
    info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
                       IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`  CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
rhs

    -- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
    --                         (a :: TYPE r1) (b :: TYPE r2).
    --                         a -> b
    bndrs :: [Id]
bndrs = [Type] -> ([Type] -> [Type]) -> [Id]
mkTemplateKiTyVars [Type
runtimeRepTy, Type
runtimeRepTy]
                               (\ks :: [Type]
ks -> (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
tYPE [Type]
ks)

    [_, _, a :: Type
a, b :: Type
b] = [Id] -> [Type]
mkTyVarTys [Id]
bndrs

    ty :: Type
ty  = [Id] -> Type -> Type
mkSpecForAllTys [Id]
bndrs (Type -> Type -> Type
mkFunTy Type
a Type
b)

    [x :: Id
x] = [Type] -> [Id]
mkTemplateLocals [Type
a]
    rhs :: CoreExpr
rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams ([Id]
bndrs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
x]) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
          CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x) (Role -> Type -> Type -> Coercion
mkUnsafeCo Role
Representational Type
a Type
b)

------------------------------------------------
nullAddrId :: Id
-- nullAddr# :: Addr#
-- The reason it is here is because we don't provide
-- a way to write this literal in Haskell.
nullAddrId :: Id
nullAddrId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
nullAddrName Type
addrPrimTy IdInfo
info
  where
    info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
                       IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`  CoreExpr -> Unfolding
mkCompulsoryUnfolding (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
nullAddrLit)
                       HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly`   Type
addrPrimTy

------------------------------------------------
seqId :: Id     -- See Note [seqId magic]
seqId :: Id
seqId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
seqName Type
ty IdInfo
info
  where
    info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
inline_prag
                       IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`  CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
rhs
                       HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly`   Type
ty

    inline_prag :: InlinePragma
inline_prag
         = InlinePragma
alwaysInlinePragma InlinePragma -> Activation -> InlinePragma
`setInlinePragmaActivation` SourceText -> Int -> Activation
ActiveAfter
                 SourceText
NoSourceText 0
                  -- Make 'seq' not inline-always, so that simpleOptExpr
                  -- (see CoreSubst.simple_app) won't inline 'seq' on the
                  -- LHS of rules.  That way we can have rules for 'seq';
                  -- see Note [seqId magic]

    ty :: Type
ty  = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar,Id
betaTyVar]
                          (Type -> Type -> Type
mkFunTy Type
alphaTy (Type -> Type -> Type
mkFunTy Type
betaTy Type
betaTy))

    [x :: Id
x,y :: Id
y] = [Type] -> [Id]
mkTemplateLocals [Type
alphaTy, Type
betaTy]
    rhs :: CoreExpr
rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
alphaTyVar,Id
betaTyVar,Id
x,Id
y] (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x) Id
x Type
betaTy [(AltCon
DEFAULT, [], Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y)])

------------------------------------------------
lazyId :: Id    -- See Note [lazyId magic]
lazyId :: Id
lazyId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
lazyIdName Type
ty IdInfo
info
  where
    info :: IdInfo
info = IdInfo
noCafIdInfo HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly` Type
ty
    ty :: Type
ty  = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] (Type -> Type -> Type
mkFunTy Type
alphaTy Type
alphaTy)

noinlineId :: Id -- See Note [noinlineId magic]
noinlineId :: Id
noinlineId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
noinlineIdName Type
ty IdInfo
info
  where
    info :: IdInfo
info = IdInfo
noCafIdInfo HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly` Type
ty
    ty :: Type
ty  = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] (Type -> Type -> Type
mkFunTy Type
alphaTy Type
alphaTy)

oneShotId :: Id -- See Note [The oneShot function]
oneShotId :: Id
oneShotId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
oneShotName Type
ty IdInfo
info
  where
    info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
                       IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`  CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
rhs
    ty :: Type
ty  = [Id] -> Type -> Type
mkSpecForAllTys [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar
                          , Id
openAlphaTyVar, Id
openBetaTyVar ]
                          (Type -> Type -> Type
mkFunTy Type
fun_ty Type
fun_ty)
    fun_ty :: Type
fun_ty = Type -> Type -> Type
mkFunTy Type
openAlphaTy Type
openBetaTy
    [body :: Id
body, x :: Id
x] = [Type] -> [Id]
mkTemplateLocals [Type
fun_ty, Type
openAlphaTy]
    x' :: Id
x' = Id -> Id
setOneShotLambda Id
x  -- Here is the magic bit!
    rhs :: CoreExpr
rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar
                 , Id
openAlphaTyVar, Id
openBetaTyVar
                 , Id
body, Id
x'] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
          Id -> CoreExpr
forall b. Id -> Expr b
Var Id
body CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x

--------------------------------------------------------------------------------
magicDictId :: Id  -- See Note [magicDictId magic]
magicDictId :: Id
magicDictId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
magicDictName Type
ty IdInfo
info
  where
  info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
neverInlinePragma
                     HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly`   Type
ty
  ty :: Type
ty   = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] Type
alphaTy

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

coerceId :: Id
coerceId :: Id
coerceId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
coerceName Type
ty IdInfo
info
  where
    info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
                       IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`  CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
rhs
                       HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly`   Type
ty
    eqRTy :: Type
eqRTy     = TyCon -> [Type] -> Type
mkTyConApp TyCon
coercibleTyCon [ Type
liftedTypeKind
                                          , Type
alphaTy, Type
betaTy ]
    eqRPrimTy :: Type
eqRPrimTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
eqReprPrimTyCon [ Type
liftedTypeKind
                                           , Type
liftedTypeKind
                                           , Type
alphaTy, Type
betaTy ]
    ty :: Type
ty        = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar, Id
betaTyVar] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                [Type] -> Type -> Type
mkFunTys [Type
eqRTy, Type
alphaTy] Type
betaTy

    [eqR :: Id
eqR,x :: Id
x,eq :: Id
eq] = [Type] -> [Id]
mkTemplateLocals [Type
eqRTy, Type
alphaTy, Type
eqRPrimTy]
    rhs :: CoreExpr
rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
alphaTyVar, Id
betaTyVar, Id
eqR, Id
x] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
          CoreExpr -> Type -> Type -> [Alt Id] -> CoreExpr
mkWildCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
eqR) Type
eqRTy Type
betaTy ([Alt Id] -> CoreExpr) -> [Alt Id] -> CoreExpr
forall a b. (a -> b) -> a -> b
$
          [(DataCon -> AltCon
DataAlt DataCon
coercibleDataCon, [Id
eq], CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x) (Id -> Coercion
mkCoVarCo Id
eq))]

{-
Note [Unsafe coerce magic]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We define a *primitive*
   GHC.Prim.unsafeCoerce#
and then in the base library we define the ordinary function
   Unsafe.Coerce.unsafeCoerce :: forall (a:*) (b:*). a -> b
   unsafeCoerce x = unsafeCoerce# x

Notice that unsafeCoerce has a civilized (albeit still dangerous)
polymorphic type, whose type args have kind *.  So you can't use it on
unboxed values (unsafeCoerce 3#).

In contrast unsafeCoerce# is even more dangerous because you *can* use
it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is
   forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a: TYPE r1) (b: TYPE r2). a -> b

Note [seqId magic]
~~~~~~~~~~~~~~~~~~
'GHC.Prim.seq' is special in several ways.

a) In source Haskell its second arg can have an unboxed type
      x `seq` (v +# w)
   But see Note [Typing rule for seq] in TcExpr, which
   explains why we give seq itself an ordinary type
         seq :: forall a b. a -> b -> b
   and treat it as a language construct from a typing point of view.

b) Its fixity is set in LoadIface.ghcPrimIface

c) It has quite a bit of desugaring magic.
   See DsUtils.hs Note [Desugaring seq (1)] and (2) and (3)

d) There is some special rule handing: Note [User-defined RULES for seq]

Note [User-defined RULES for seq]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Roman found situations where he had
      case (f n) of _ -> e
where he knew that f (which was strict in n) would terminate if n did.
Notice that the result of (f n) is discarded. So it makes sense to
transform to
      case n of _ -> e

Rather than attempt some general analysis to support this, I've added
enough support that you can do this using a rewrite rule:

  RULE "f/seq" forall n.  seq (f n) = seq n

You write that rule.  When GHC sees a case expression that discards
its result, it mentally transforms it to a call to 'seq' and looks for
a RULE.  (This is done in Simplify.trySeqRules.)  As usual, the
correctness of the rule is up to you.

VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2.
If we wrote
  RULE "f/seq" forall n e.  seq (f n) e = seq n e
with rule arity 2, then two bad things would happen:

  - The magical desugaring done in Note [seqId magic] item (c)
    for saturated application of 'seq' would turn the LHS into
    a case expression!

  - The code in Simplify.rebuildCase would need to actually supply
    the value argument, which turns out to be awkward.

Note [lazyId magic]
~~~~~~~~~~~~~~~~~~~
lazy :: forall a?. a? -> a?   (i.e. works for unboxed types too)

'lazy' is used to make sure that a sub-expression, and its free variables,
are truly used call-by-need, with no code motion.  Key examples:

* pseq:    pseq a b = a `seq` lazy b
  We want to make sure that the free vars of 'b' are not evaluated
  before 'a', even though the expression is plainly strict in 'b'.

* catch:   catch a b = catch# (lazy a) b
  Again, it's clear that 'a' will be evaluated strictly (and indeed
  applied to a state token) but we want to make sure that any exceptions
  arising from the evaluation of 'a' are caught by the catch (see
  Trac #11555).

Implementing 'lazy' is a bit tricky:

* It must not have a strictness signature: by being a built-in Id,
  all the info about lazyId comes from here, not from GHC.Base.hi.
  This is important, because the strictness analyser will spot it as
  strict!

* It must not have an unfolding: it gets "inlined" by a HACK in
  CorePrep. It's very important to do this inlining *after* unfoldings
  are exposed in the interface file.  Otherwise, the unfolding for
  (say) pseq in the interface file will not mention 'lazy', so if we
  inline 'pseq' we'll totally miss the very thing that 'lazy' was
  there for in the first place. See Trac #3259 for a real world
  example.

* Suppose CorePrep sees (catch# (lazy e) b).  At all costs we must
  avoid using call by value here:
     case e of r -> catch# r b
  Avoiding that is the whole point of 'lazy'.  So in CorePrep (which
  generate the 'case' expression for a call-by-value call) we must
  spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let'
  instead.

* lazyId is defined in GHC.Base, so we don't *have* to inline it.  If it
  appears un-applied, we'll end up just calling it.

Note [noinlineId magic]
~~~~~~~~~~~~~~~~~~~~~~~
noinline :: forall a. a -> a

'noinline' is used to make sure that a function f is never inlined,
e.g., as in 'noinline f x'.  Ordinarily, the identity function with NOINLINE
could be used to achieve this effect; however, this has the unfortunate
result of leaving a (useless) call to noinline at runtime.  So we have
a little bit of magic to optimize away 'noinline' after we are done
running the simplifier.

'noinline' needs to be wired-in because it gets inserted automatically
when we serialize an expression to the interface format. See
Note [Inlining and hs-boot files] in ToIface

Note [The oneShot function]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the context of making left-folds fuse somewhat okish (see ticket #7994
and Note [Left folds via right fold]) it was determined that it would be useful
if library authors could explicitly tell the compiler that a certain lambda is
called at most once. The oneShot function allows that.

'oneShot' is levity-polymorphic, i.e. the type variables can refer to unlifted
types as well (Trac #10744); e.g.
   oneShot (\x:Int# -> x +# 1#)

Like most magic functions it has a compulsory unfolding, so there is no need
for a real definition somewhere. We have one in GHC.Magic for the convenience
of putting the documentation there.

It uses `setOneShotLambda` on the lambda's binder. That is the whole magic:

A typical call looks like
     oneShot (\y. e)
after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get
     (\f \x[oneshot]. f x) (\y. e)
 --> \x[oneshot]. ((\y.e) x)
 --> \x[oneshot] e[x/y]
which is what we want.

It is only effective if the one-shot info survives as long as possible; in
particular it must make it into the interface in unfoldings. See Note [Preserve
OneShotInfo] in CoreTidy.

Also see https://ghc.haskell.org/trac/ghc/wiki/OneShot.


Note [magicDictId magic]
~~~~~~~~~~~~~~~~~~~~~~~~~
The identifier `magicDict` is just a place-holder, which is used to
implement a primitive that we cannot define in Haskell but we can write
in Core.  It is declared with a place-holder type:

    magicDict :: forall a. a

The intention is that the identifier will be used in a very specific way,
to create dictionaries for classes with a single method.  Consider a class
like this:

   class C a where
     f :: T a

We are going to use `magicDict`, in conjunction with a built-in Prelude
rule, to cast values of type `T a` into dictionaries for `C a`.  To do
this, we define a function like this in the library:

  data WrapC a b = WrapC (C a => Proxy a -> b)

  withT :: (C a => Proxy a -> b)
        ->  T a -> Proxy a -> b
  withT f x y = magicDict (WrapC f) x y

The purpose of `WrapC` is to avoid having `f` instantiated.
Also, it avoids impredicativity, because `magicDict`'s type
cannot be instantiated with a forall.  The field of `WrapC` contains
a `Proxy` parameter which is used to link the type of the constraint,
`C a`, with the type of the `Wrap` value being made.

Next, we add a built-in Prelude rule (see prelude/PrelRules.hs),
which will replace the RHS of this definition with the appropriate
definition in Core.  The rewrite rule works as follows:

  magicDict @t (wrap @a @b f) x y
---->
  f (x `cast` co a) y

The `co` coercion is the newtype-coercion extracted from the type-class.
The type class is obtain by looking at the type of wrap.


-------------------------------------------------------------
@realWorld#@ used to be a magic literal, \tr{void#}.  If things get
nasty as-is, change it back to a literal (@Literal@).

voidArgId is a Local Id used simply as an argument in functions
where we just want an arg to avoid having a thunk of unlifted type.
E.g.
        x = \ void :: Void# -> (# p, q #)

This comes up in strictness analysis

Note [evaldUnfoldings]
~~~~~~~~~~~~~~~~~~~~~~
The evaldUnfolding makes it look that some primitive value is
evaluated, which in turn makes Simplify.interestingArg return True,
which in turn makes INLINE things applied to said value likely to be
inlined.
-}

realWorldPrimId :: Id   -- :: State# RealWorld
realWorldPrimId :: Id
realWorldPrimId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
realWorldName Type
realWorldStatePrimTy
                     (IdInfo
noCafIdInfo IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
evaldUnfolding    -- Note [evaldUnfoldings]
                                  IdInfo -> OneShotInfo -> IdInfo
`setOneShotInfo` OneShotInfo
stateHackOneShot
                                  HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly` Type
realWorldStatePrimTy)

voidPrimId :: Id     -- Global constant :: Void#
voidPrimId :: Id
voidPrimId  = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
voidPrimIdName Type
voidPrimTy
                (IdInfo
noCafIdInfo IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
evaldUnfolding     -- Note [evaldUnfoldings]
                             HasDebugCallStack => IdInfo -> Type -> IdInfo
IdInfo -> Type -> IdInfo
`setNeverLevPoly`  Type
voidPrimTy)

voidArgId :: Id       -- Local lambda-bound :: Void#
voidArgId :: Id
voidArgId = RuleName -> Unique -> Type -> Id
mkSysLocal (String -> RuleName
fsLit "void") Unique
voidArgIdKey Type
voidPrimTy

coercionTokenId :: Id         -- :: () ~ ()
coercionTokenId :: Id
coercionTokenId -- Used to replace Coercion terms when we go to STG
  = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
coercionTokenName
                 (TyCon -> [Type] -> Type
mkTyConApp TyCon
eqPrimTyCon [Type
liftedTypeKind, Type
liftedTypeKind, Type
unitTy, Type
unitTy])
                 IdInfo
noCafIdInfo

pcMiscPrelId :: Name -> Type -> IdInfo -> Id
pcMiscPrelId :: Name -> Type -> IdInfo -> Id
pcMiscPrelId name :: Name
name ty :: Type
ty info :: IdInfo
info
  = Name -> Type -> IdInfo -> Id
mkVanillaGlobalWithInfo Name
name Type
ty IdInfo
info
    -- We lie and say the thing is imported; otherwise, we get into
    -- a mess with dependency analysis; e.g., core2stg may heave in
    -- random calls to GHCbase.unpackPS__.  If GHCbase is the module
    -- being compiled, then it's just a matter of luck if the definition
    -- will be in "the right place" to be in scope.