{-
(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
-}



{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module GHC.Types.Id.Make (
        mkDictFunId, mkDictSelId, mkDictSelRhs,

        mkFCallId,

        unwrapNewTypeBody, wrapFamInstBody,
        DataConBoxer(..), vanillaDataConBoxer,
        mkDataConRep, mkDataConWorkId,
        DataConBangOpts (..), BangOpts (..),
        unboxedUnitExpr,

        -- And some particular Ids; see below for why they are wired in
        wiredInIds, ghcPrimIds,
        realWorldPrimId,
        voidPrimId, voidArgId,
        nullAddrId, seqId, lazyId, lazyIdKey,
        coercionTokenId, coerceId,
        proxyHashId,
        nospecId, nospecIdName,
        noinlineId, noinlineIdName,
        noinlineConstraintId, noinlineConstraintIdName,
        coerceName, leftSectionName, rightSectionName,
    ) where

import GHC.Prelude

import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
import GHC.Builtin.Names

import GHC.Core
import GHC.Core.Opt.Arity( typeOneShot )
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.TyCo.Rep
import GHC.Core.FamInstEnv
import GHC.Core.Coercion
import GHC.Core.Reduction
import GHC.Core.Make
import GHC.Core.FVs     ( mkRuleInfo )
import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, coreAltsType )
import GHC.Core.Unfold.Make
import GHC.Core.SimpleOpt
import GHC.Core.TyCon
import GHC.Core.Class
import GHC.Core.DataCon

import GHC.Types.Literal
import GHC.Types.SourceText
import GHC.Types.RepType ( countFunRepArgs )
import GHC.Types.Name.Set
import GHC.Types.Name
import GHC.Types.ForeignCall
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Types.Unique.Supply
import GHC.Types.Basic       hiding ( SuccessFlag(..) )
import GHC.Types.Var (VarBndr(Bndr), visArgConstraintLike)

import GHC.Tc.Utils.TcType as TcType

import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain

import GHC.Data.FastString
import GHC.Data.List.SetOps
import Data.List        ( zipWith4 )

-- A bit of a shame we must import these here
import GHC.StgToCmm.Types (LambdaFormInfo(..))
import GHC.Runtime.Heap.Layout (ArgDescr(ArgUnknown))

{-
************************************************************************
*                                                                      *
\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 GHC.Core.Make.
  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 (see ghcPrimExports, used in ghcPrimInterface)
    See Note [GHC.Prim] in primops.txt.pp for the remaining items in 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. realWorldPrimId)

  * 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.

  * May have IdInfo that differs from what would be imported from GHC.Magic.hi.
    For example, 'lazy' gets a lazy strictness signature, per Note [lazyId magic].

  The two remaining identifiers in GHC.Magic, runRW# and inline, are not listed
  in magicIds: they have special behavior but they can be known-key and
  not wired-in.
  runRW#: see Note [Simplification of runRW#] in Prep, runRW# code in
  Simplifier, Note [Linting of runRW#].
  inline: see Note [inlineId magic]
-}

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 GHC.Core.Make

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

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

{-
************************************************************************
*                                                                      *
\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 have no existentials. It's
not quite a "vanilla" data constructor, because the newtype arising from
     class C a => D a
looks like
       newtype T:D a = C:D (C a)
so the data constructor for T:C has a single argument, namely the
predicate (C a).  That ends up in the dcOtherTheta for the data con,
which makes it not vanilla.  So the assert just tests for existentials.
The rest is checked by having a singleton arg_tys.

Note [Newtype workers]
~~~~~~~~~~~~~~~~~~~~~~
A newtype does not really have a worker. Instead, newtype constructors
just unfold into a cast. But we need *something* for, say, MkAge to refer
to. So, we do this:

* The Id used as the newtype worker will have a compulsory unfolding to
  a cast. See Note [Compulsory newtype unfolding]

* This Id is labeled as a DataConWrapId. We don't want to use a DataConWorkId,
  as those have special treatment in the back end.

* There is no top-level binding, because the compulsory unfolding
  means that it will be inlined (to a cast) at every call site.

We probably should have a NewtypeWorkId, but these Ids disappear as soon as
we desugar anyway, so it seems a step too far.

Note [Compulsory newtype unfolding]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Newtype wrappers, just like workers, have compulsory unfoldings.
This is needed so that two optimizations involving newtypes have the same
effect whether a wrapper is present or not:

(1) Case-of-known constructor.
    See Note [beta-reduction in exprIsConApp_maybe].

(2) Matching against the map/coerce RULE. Suppose we have the RULE

    {-# RULE "map/coerce" map coerce = ... #-}

    As described in Note [Getting the map/coerce RULE to work],
    the occurrence of 'coerce' is transformed into:

    {-# RULE "map/coerce" forall (c :: T1 ~R# T2).
                          map ((\v -> v) `cast` c) = ... #-}

    We'd like 'map Age' to match the LHS. For this to happen, Age
    must be unfolded, otherwise we'll be stuck. This is tested in T16208.

It also allows for the possibility of representation-polymorphic newtypes
with wrappers (with -XUnliftedNewtypes):

  newtype N (a :: TYPE r) = MkN a

With -XUnliftedNewtypes, this is allowed -- even though MkN is representation-
polymorphic. It's OK because MkN evaporates in the compiled code, becoming
just a cast. That is, it has a compulsory unfolding. As long as its
argument is not representation-polymorphic (which it can't be, according to
Note [Representation polymorphism invariants] in GHC.Core), and it's saturated,
no representation-polymorphic code ends up in the code generator.
The saturation condition is effectively checked in
GHC.Tc.Gen.App.hasFixedRuntimeRep_remainingValArgs.

However, if we make a *wrapper* for a newtype, we get into trouble.
In that case, we generate a forbidden representation-polymorphic
binding, and we must then ensure that it is always instantiated
at a representation-monomorphic type.

The solution is simple, though: just make the newtype wrappers
as ephemeral as the newtype workers. In other words, give the wrappers
compulsory unfoldings and no bindings. The compulsory unfolding is given
in wrap_unf in mkDataConRep, and the lack of a binding happens in
GHC.Iface.Tidy.getTyConImplicitBinds, where we say that a newtype has no
implicit bindings.

Note [Records and linear types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
All the fields, in a record constructor, are linear, because there is no syntax
to specify the type of record field. There will be (see the proposal
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst#records-and-projections
), but it isn't implemented yet.

Projections of records can't be linear:

  data Foo = MkFoo { a :: A, b :: B }

If we had

  a :: Foo %1 -> A

We could write

  bad :: A %1 -> B %1 -> A
  bad x y = a (MkFoo { a=x, b=y })

There is an exception: if `b` (more generally all the fields besides `a`) is
unrestricted, then is perfectly possible to have a linear projection. Such a
linear projection has as simple definition.

  data Bar = MkBar { c :: C, d % Many :: D }

  c :: Bar %1 -> C
  c MkBar{ c=x, d=_} = x

The `% Many` syntax, for records, does not exist yet. But there is one important
special case which already happens: when there is a single field (usually a
newtype).

  newtype Baz = MkBaz { unbaz :: E }

unbaz could be linear. And, in fact, it is linear in the proposal design.

However, this hasn't been implemented yet.

************************************************************************
*                                                                      *
\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

Note [Type classes and linear types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Constraints, in particular type classes, don't have attached linearity
information. Implicitly, they are all unrestricted. See the linear types proposal,
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst .

When translating to core `C => ...` is always translated to an unrestricted
arrow `C % Many -> ...`.

Therefore there is no loss of generality if we make all selectors unrestricted.

-}

mkDictSelId :: Name          -- Name of one of the *value* selectors
                             -- (dictionary superclass or method)
            -> Class -> Id
mkDictSelId :: Name -> Class -> Id
mkDictSelId Name
name Class
clas
  = IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId (Class -> Bool -> IdDetails
ClassOpId Class
clas Bool
terminating) 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
    [DataCon
data_con]     = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
    tyvars :: [InvisTVBinder]
tyvars         = DataCon -> [InvisTVBinder]
dataConUserTyVarBinders DataCon
data_con
    n_ty_args :: Int
n_ty_args      = [InvisTVBinder] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [InvisTVBinder]
tyvars
    arg_tys :: [Scaled Type]
arg_tys        = DataCon -> [Scaled 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 String
"MkId.mkDictSelId" ([Name]
sel_names [Name] -> [Int] -> Assoc Name Int
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0..]) Name
name

    pred_ty :: Type
pred_ty = Class -> [Type] -> Type
mkClassPred Class
clas ([Id] -> [Type]
mkTyVarTys ([InvisTVBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
tyvars))
    res_ty :: Type
res_ty  = Scaled Type -> Type
forall a. Scaled a -> a
scaledThing ([Scaled Type] -> Int -> Scaled Type
forall a. Outputable a => [a] -> Int -> a
getNth [Scaled Type]
arg_tys Int
val_index)
    sel_ty :: Type
sel_ty  = [InvisTVBinder] -> Type -> Type
mkInvisForAllTys [InvisTVBinder]
tyvars (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
              HasDebugCallStack => Type -> Type -> Type -> Type
Type -> Type -> Type -> Type
mkFunctionType Type
ManyTy Type
pred_ty Type
res_ty
             -- See Note [Type classes and linear types]

    terminating :: Bool
terminating = HasDebugCallStack => Type -> Bool
Type -> Bool
isTerminatingType Type
res_ty Bool -> Bool -> Bool
|| Type -> Bool
definitelyUnliftedType Type
res_ty
                  -- If the field is unlifted, it can't be bottom
                  -- Ditto if it's a terminating type

    base_info :: IdInfo
base_info = IdInfo
noCafIdInfo
                IdInfo -> Int -> IdInfo
`setArityInfo`  Int
1
                IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` DmdSig
strict_sig
                IdInfo -> CprSig -> IdInfo
`setCprSigInfo` CprSig
topCprSig

    info :: IdInfo
info | Bool
new_tycon
         = IdInfo
base_info IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
                     IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`  SimpleOpts -> UnfoldingSource -> Int -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity SimpleOpts
defaultSimpleOpts
                                           UnfoldingSource
StableSystemSrc Int
1
                                           (Class -> Int -> CoreExpr
mkDictSelRhs Class
clas Int
val_index)
                   -- See Note [Single-method classes] in GHC.Tc.TyCl.Instance
                   -- for why alwaysInlinePragma

         | Bool
otherwise
         = IdInfo
base_info IdInfo -> RuleInfo -> IdInfo
`setRuleInfo` [CoreRule] -> RuleInfo
mkRuleInfo [CoreRule
rule]
                     IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
neverInlinePragma
                     IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`  SimpleOpts -> UnfoldingSource -> Int -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity SimpleOpts
defaultSimpleOpts
                                           UnfoldingSource
StableSystemSrc Int
1
                                           (Class -> Int -> CoreExpr
mkDictSelRhs Class
clas Int
val_index)
                   -- Add a magic BuiltinRule, but no unfolding
                   -- so that the rule is always available to fire.
                   -- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance

    -- This is the built-in rule that goes
    --      op (dfT d1 d2) --->  opT d1 d2
    rule :: CoreRule
rule = BuiltinRule { ru_name :: RuleName
ru_name = String -> RuleName
fsLit String
"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
+ Int
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 :: DmdSig
strict_sig = [Demand] -> Divergence -> DmdSig
mkClosedDmdSig [Demand
arg_dmd] Divergence
topDiv
    arg_dmd :: Demand
arg_dmd | Bool
new_tycon = Demand
evalDmd
            | Bool
otherwise = Card
C_1N HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* Boxity -> [Demand] -> SubDemand
mkProd Boxity
Unboxed [Demand]
dict_field_dmds
            where
              -- The evalDmd below is just a placeholder and will be replaced in
              -- GHC.Types.Demand.dmdTransformDictSel
              dict_field_dmds :: [Demand]
dict_field_dmds = [ 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 Class
clas 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
    [DataCon
data_con]     = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
    tyvars :: [Id]
tyvars         = DataCon -> [Id]
dataConUnivTyVars DataCon
data_con
    arg_tys :: [Scaled Type]
arg_tys        = DataCon -> [Scaled 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 Int
1 Type
pred
    arg_ids :: [Id]
arg_ids        = Int -> [Type] -> [Id]
mkTemplateLocalsNum Int
2 ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled 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 -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
dict_id) Id
dict_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 Int
val_index Int
n_ty_args RuleOpts
_ InScopeEnv
id_unf Id
_ [CoreExpr]
args
  | (CoreExpr
dict_arg : [CoreExpr]
_) <- Int -> [CoreExpr] -> [CoreExpr]
forall a. Int -> [a] -> [a]
drop Int
n_ty_args [CoreExpr]
args
  , Just (InScopeSet
_, [FloatBind]
floats, DataCon
_, [Type]
_, [CoreExpr]
con_args) <- HasDebugCallStack =>
InScopeEnv
-> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
InScopeEnv
-> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe InScopeEnv
id_unf CoreExpr
dict_arg
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just ([FloatBind] -> CoreExpr -> CoreExpr
wrapFloats [FloatBind]
floats (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ [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 Name
wkr_name 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
      -- See Note [Newtype workers]

  | 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 -> InlinePragma -> IdInfo
`setInlinePragInfo`     InlinePragma
wkr_inline_prag
                   IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`      Unfolding
evaldUnfolding  -- Record that it's evaluated,
                                                           -- even if arity = 0
                   IdInfo -> LambdaFormInfo -> IdInfo
`setLFInfo`             LambdaFormInfo
wkr_lf_info
          -- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon

    wkr_inline_prag :: InlinePragma
wkr_inline_prag = InlinePragma
defaultInlinePragma { inl_rule = ConLike }
    wkr_arity :: Int
wkr_arity = DataCon -> Int
dataConRepArity DataCon
data_con

    -- See Note [LFInfo of DataCon workers and wrappers]
    wkr_lf_info :: LambdaFormInfo
wkr_lf_info
      | Int
wkr_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = DataCon -> LambdaFormInfo
LFCon DataCon
data_con
      | Bool
otherwise      = TopLevelFlag -> Int -> Bool -> ArgDescr -> LambdaFormInfo
LFReEntrant TopLevelFlag
TopLevel (Int -> Type -> Int
countFunRepArgs Int
wkr_arity Type
wkr_ty) Bool
True ArgDescr
ArgUnknown
                                            -- LFInfo stores post-unarisation arity

    ----------- Workers for newtypes --------------
    univ_tvs :: [Id]
univ_tvs = DataCon -> [Id]
dataConUnivTyVars DataCon
data_con
    ex_tcvs :: [Id]
ex_tcvs  = DataCon -> [Id]
dataConExTyCoVars DataCon
data_con
    arg_tys :: [Scaled Type]
arg_tys  = DataCon -> [Scaled 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` Int
1      -- Arity 1
                  IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo`     InlinePragma
dataConWrapperInlinePragma
                  IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`      Unfolding
newtype_unf
                               -- See W1 in Note [LFInfo of DataCon workers and wrappers]
                  IdInfo -> LambdaFormInfo -> IdInfo
`setLFInfo` (String -> LambdaFormInfo
forall a. HasCallStack => String -> a
panic String
"mkDataConWorkId: we shouldn't look at LFInfo for newtype worker ids")
    id_arg1 :: Id
id_arg1      = Int -> Scaled Type -> Id
mkScaledTemplateLocal Int
1 ([Scaled Type] -> Scaled Type
forall a. HasCallStack => [a] -> a
head [Scaled Type]
arg_tys)
    res_ty_args :: [Type]
res_ty_args  = [Id] -> [Type]
mkTyCoVarTys [Id]
univ_tvs
    newtype_unf :: Unfolding
newtype_unf  = Bool -> SDoc -> (CoreExpr -> Unfolding) -> CoreExpr -> Unfolding
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
ex_tcvs Bool -> Bool -> Bool
&& [Scaled Type] -> Bool
forall a. [a] -> Bool
isSingleton [Scaled Type]
arg_tys)
                             (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
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)

{-
Note [LFInfo of DataCon workers and wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As noted in Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure, it's
crucial that saturated data con applications are given an LFInfo of `LFCon`.

Since for data constructors we never serialise the worker and the wrapper (only
the data type declaration), we never serialise their lambda form info either.

Therefore, when making data constructors workers and wrappers, we construct a
correct `LFInfo` for them right away, and put it it in the `lfInfo` field of the
worker/wrapper Id, ensuring that:

  The `lfInfo` field of a DataCon worker or wrapper is always populated with the correct LFInfo.

How do we construct a /correct/ LFInfo for workers and wrappers?
(Remember: `LFCon` means "a saturated constructor application")

(1) Data constructor workers and wrappers with arity > 0 are unambiguously
functions and should be given `LFReEntrant`, regardless of the runtime
relevance of the arguments.
  - For example, `Just :: a -> Maybe a` is given `LFReEntrant`,
             and `HNil :: (a ~# '[]) -> HList a` is given `LFReEntrant` too.

(2) A datacon /worker/ with zero arity is trivially fully saturated -- it takes
no arguments whatsoever (not even zero-width args), so it is given `LFCon`.

(3) Perhaps surprisingly, a datacon /wrapper/ can be an `LFCon`. See Wrinkle (W1) below.
A datacon /wrapper/ with zero arity must be a fully saturated application of
the worker to zero-width arguments only (which are dropped after unarisation),
and therefore is also given `LFCon`.

For example, consider the following data constructors:

  data T1 a where
    TCon1 :: {-# UNPACK #-} !(a :~: True) -> T1 a

  data T2 a where
    TCon2 :: {-# UNPACK #-} !() -> T2 a

  data T3 a where
    TCon3 :: T3 '[]

`TCon1`'s wrapper has a lifted argument, which is non-zero-width, while the
worker has an unlifted equality argument, which is zero-width.

`TCon2`'s wrapper has a lifted argument, which is non-zero-width, while the
worker has no arguments.

Wrinkle (W1). Perhaps surprisingly, it is possible for the /wrapper/ to be an
`LFCon` even though the /worker/ is not. Consider `T3` above. Here is the
Core representation of the worker and wrapper:

  $WTCon3 :: T3 '[]             -- Wrapper
  $WTCon3 = TCon3 @[] <Refl>    -- A saturated constructor application: LFCon

  TCon3 :: forall (a :: * -> *). (a ~# []) => T a   -- Worker
  TCon3 = /\a. \(co :: a~#[]). TCon3 co             -- A function: LFReEntrant

For `TCon1`, both the wrapper and worker will be given `LFReEntrant` since they
both have arity == 1.

For `TCon2`, the wrapper will be given `LFReEntrant` since it has arity == 1
while the worker is `LFCon` since its arity == 0

For `TCon3`, the wrapper will be given `LFCon` since its arity == 0 and the
worker `LFReEntrant` since its arity == 1

One might think we could give *workers* with only zero-width-args the `LFCon`
LambdaFormInfo, e.g. give `LFCon` to the worker of `TCon1` and `TCon3`.
However, these workers are unambiguously functions
-- which makes `LFReEntrant`, the LambdaFormInfo we give them, correct.
See also the discussion in #23158.

Wrinkles:

(W1) Why do we panic when generating `LFInfo` for newtype workers and wrappers?

  We don't generate code for newtype workers/wrappers, so we should never have to
  look at their LFInfo (and in general we can't; they may be representation-polymorphic).

See also the Note [Imported unlifted nullary datacon wrappers must have correct LFInfo]
in GHC.StgToCmm.Types.

-------------------------------------------------
--         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 (Subst -> 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

vanillaDataConBoxer :: DataConBoxer
-- No transformation on arguments needed
vanillaDataConBoxer :: DataConBoxer
vanillaDataConBoxer = ([Type] -> [Id] -> UniqSM ([Id], [CoreBind])) -> DataConBoxer
DCB (\[Type]
_tys [Id]
args -> ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
args, []))

{-
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.

-}

data DataConBangOpts
  = FixedBangOpts [HsImplBang]
    -- ^ Used for imported data constructors
    -- See Note [Bangs on imported data constructors]
  | SrcBangOpts !BangOpts

data BangOpts = BangOpts
  { BangOpts -> Bool
bang_opt_strict_data   :: !Bool -- ^ Strict fields by default
  , BangOpts -> Bool
bang_opt_unbox_disable :: !Bool -- ^ Disable automatic field unboxing (e.g. if we aren't optimising)
  , BangOpts -> Bool
bang_opt_unbox_strict  :: !Bool -- ^ Unbox strict fields
  , BangOpts -> Bool
bang_opt_unbox_small   :: !Bool -- ^ Unbox small strict fields
  }

mkDataConRep :: DataConBangOpts
             -> FamInstEnvs
             -> Name
             -> DataCon
             -> UniqSM DataConRep
mkDataConRep :: DataConBangOpts
-> FamInstEnvs -> Name -> DataCon -> UniqSM DataConRep
mkDataConRep DataConBangOpts
dc_bang_opts FamInstEnvs
fam_envs Name
wrap_name DataCon
data_con
  | Bool -> Bool
not Bool
wrapper_reqd
  = DataConRep -> UniqSM DataConRep
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return DataConRep
NoDataConRep

  | Bool
otherwise
  = do { [Id]
wrap_args <- (Scaled Type -> UniqSM Id) -> [Scaled Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (RuleName -> Scaled Type -> UniqSM Id
newLocal (String -> RuleName
fsLit String
"conrep")) [Scaled Type]
wrap_arg_tys
       ; CoreExpr
wrap_body <- [(Id, Unboxer)] -> CoreExpr -> UniqSM CoreExpr
mk_rep_app ([Type] -> [Id] -> [Id]
forall b a. [b] -> [a] -> [a]
dropList [Type]
stupid_theta [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
initial_wrap_app
                        -- Drop the stupid theta arguments, as per
                        -- Note [Instantiating stupid theta] in GHC.Core.DataCon.

       ; 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 -> DmdSig -> IdInfo
`setDmdSigInfo`        DmdSig
wrap_sig
                             -- We need to get the CAF info right here because GHC.Iface.Tidy
                             -- does not tidy the IdInfo of implicit bindings (like the wrapper)
                             -- so it not make sure that the CAF info is sane
                         IdInfo -> LambdaFormInfo -> IdInfo
`setLFInfo`            LambdaFormInfo
wrap_lf_info

             -- The signature is purely for passes like the Simplifier, not for
             -- DmdAnal itself; see Note [DmdAnal for DataCon wrappers].
             wrap_sig :: DmdSig
wrap_sig = [Demand] -> Divergence -> DmdSig
mkClosedDmdSig [Demand]
wrap_arg_dmds Divergence
topDiv

             -- See Note [LFInfo of DataCon workers and wrappers]
             wrap_lf_info :: LambdaFormInfo
wrap_lf_info
               | Int
wrap_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0  = DataCon -> LambdaFormInfo
LFCon DataCon
data_con
               -- See W1 in Note [LFInfo of DataCon workers and wrappers]
               | TyCon -> Bool
isNewTyCon TyCon
tycon = String -> LambdaFormInfo
forall a. HasCallStack => String -> a
panic String
"mkDataConRep: we shouldn't look at LFInfo for newtype wrapper ids"
               | Bool
otherwise        = TopLevelFlag -> Int -> Bool -> ArgDescr -> LambdaFormInfo
LFReEntrant TopLevelFlag
TopLevel (Int -> Type -> Int
countFunRepArgs Int
wrap_arity Type
wrap_ty) Bool
True ArgDescr
ArgUnknown
                                                      -- LFInfo stores post-unarisation arity

             wrap_arg_dmds :: [Demand]
wrap_arg_dmds =
               Int -> Demand -> [Demand]
forall a. Int -> a -> [a]
replicate ([Type] -> Int
forall a. [a] -> 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 HsImplBang
str | HsImplBang -> Bool
isBanged HsImplBang
str = Demand
evalDmd
                        | Bool
otherwise    = Demand
topDmd

             wrap_prag :: InlinePragma
wrap_prag = InlinePragma
dataConWrapperInlinePragma
                         InlinePragma -> Activation -> InlinePragma
`setInlinePragmaActivation` Activation
activateDuringFinal
                         -- 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 | TyCon -> Bool
isNewTyCon TyCon
tycon = CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
wrap_rhs
                        -- See Note [Compulsory newtype unfolding]
                      | Bool
otherwise        = CoreExpr -> Unfolding
mkDataConUnfolding 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 a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: [Scaled Type]
dcr_arg_tys = [Scaled 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
    ([Id]
univ_tvs, [Id]
ex_tvs, [EqSpec]
eq_spec, [Type]
theta, [Scaled Type]
orig_arg_tys, Type
_orig_res_ty)
                 = DataCon -> ([Id], [Id], [EqSpec], [Type], [Scaled Type], Type)
dataConFullSig DataCon
data_con
    stupid_theta :: [Type]
stupid_theta = DataCon -> [Type]
dataConStupidTheta DataCon
data_con
    wrap_tvs :: [Id]
wrap_tvs     = DataCon -> [Id]
dataConUserTyVars DataCon
data_con
    res_ty_args :: [Type]
res_ty_args  = DataCon -> [Type]
dataConResRepTyArgs DataCon
data_con

    tycon :: TyCon
tycon        = DataCon -> TyCon
dataConTyCon DataCon
data_con       -- The representation TyCon (not family)
    wrap_ty :: Type
wrap_ty      = DataCon -> Type
dataConWrapperType 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 :: [Scaled Type]
all_arg_tys  = (Type -> Scaled Type) -> [Type] -> [Scaled Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Scaled Type
forall a. a -> Scaled a
unrestricted [Type]
ev_tys [Scaled Type] -> [Scaled Type] -> [Scaled Type]
forall a. [a] -> [a] -> [a]
++ [Scaled 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 :: [Scaled Type]
wrap_arg_tys = ((Type -> Scaled Type) -> [Type] -> [Scaled Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Scaled Type
forall a. a -> Scaled a
unrestricted ([Type] -> [Scaled Type]) -> [Type] -> [Scaled Type]
forall a b. (a -> b) -> a -> b
$ [Type]
stupid_theta [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
theta) [Scaled Type] -> [Scaled Type] -> [Scaled Type]
forall a. [a] -> [a] -> [a]
++ [Scaled 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
+ [Scaled Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled 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
      = (Scaled Type -> HsImplBang) -> [Scaled Type] -> [HsImplBang]
forall a b. (a -> b) -> [a] -> [b]
map (HsImplBang -> Scaled Type -> HsImplBang
forall a b. a -> b -> a
const HsImplBang
HsLazy) [Scaled Type]
orig_arg_tys -- See Note [HsImplBangs for newtypes]
                                        -- orig_arg_tys should be a singleton, but
                                        -- if a user declared a wrong newtype we
                                        -- detect this later (see test T2334A)
      | Bool
otherwise
      = case DataConBangOpts
dc_bang_opts of
          SrcBangOpts BangOpts
bang_opts -> (Scaled Type -> HsSrcBang -> HsImplBang)
-> [Scaled Type] -> [HsSrcBang] -> [HsImplBang]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (BangOpts -> FamInstEnvs -> Scaled Type -> HsSrcBang -> HsImplBang
dataConSrcToImplBang BangOpts
bang_opts FamInstEnvs
fam_envs)
                                    [Scaled Type]
orig_arg_tys [HsSrcBang]
orig_bangs
          FixedBangOpts [HsImplBang]
bangs   -> [HsImplBang]
bangs

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

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

    -- This is True if the data constructor or class dictionary constructor
    -- needs a wrapper. This wrapper is injected into the program later in the
    -- CoreTidy pass. See Note [Injecting implicit bindings] in GHC.Iface.Tidy,
    -- along with the accompanying implementation in getTyConImplicitBinds.
    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 dataConUserTyVarsNeedWrapper 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
|| TyCon -> Bool
isFamInstTyCon TyCon
tycon -- Cast result
      Bool -> Bool -> Bool
|| (DataCon -> Bool
dataConUserTyVarsNeedWrapper 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].
                     --
                     -- NB: All GADTs return true from this function, but there
                     -- is one exception that we must check below.
         Bool -> Bool -> Bool
&& Bool -> Bool
not (TyCon -> Bool
isTypeDataTyCon TyCon
tycon))
                     -- An exception to this rule is `type data` declarations.
                     -- Their data constructors only live at the type level and
                     -- therefore do not need wrappers.
                     -- See Note [Type data declarations] in GHC.Rename.Module.
                     --
                     -- Note that the other checks in this definition will
                     -- return False for `type data` declarations, as:
                     --
                     -- - They cannot be newtypes
                     -- - They cannot have strict fields
                     -- - They cannot be data family instances
                     -- - They cannot have datatype contexts
      Bool -> Bool -> Bool
|| Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
stupid_theta)
                     -- If the data constructor has a datatype context,
                     -- we need a wrapper in order to drop the stupid arguments.
                     -- See Note [Instantiating stupid theta] in GHC.Core.DataCon.

    initial_wrap_app :: CoreExpr
initial_wrap_app = Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
data_con)
                       CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps`  [Type]
res_ty_args
                       CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
`mkVarApps` [Id]
ex_tvs
                       CoreExpr -> [Coercion] -> CoreExpr
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 [Boxer]
boxers = ([Type] -> [Id] -> UniqSM ([Id], [CoreBind])) -> DataConBoxer
DCB (\ [Type]
ty_args [Id]
src_vars ->
                      do { let ([Id]
ex_vars, [Id]
term_vars) = [Id] -> [Id] -> ([Id], [Id])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [Id]
ex_tvs [Id]
src_vars
                               subst1 :: Subst
subst1 = [Id] -> [Type] -> Subst
HasDebugCallStack => [Id] -> [Type] -> Subst
zipTvSubst [Id]
univ_tvs [Type]
ty_args
                               subst2 :: Subst
subst2 = Subst -> [Id] -> [Type] -> Subst
extendTCvSubstList Subst
subst1 [Id]
ex_tvs
                                                           ([Id] -> [Type]
mkTyCoVarTys [Id]
ex_vars)
                         ; ([Id]
rep_ids, [CoreBind]
binds) <- Subst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
go Subst
subst2 [Boxer]
boxers [Id]
term_vars
                         ; ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall a. a -> UniqSM a
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 :: Subst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
go Subst
_ [] [Id]
src_vars = Bool
-> SDoc -> UniqSM ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
src_vars) (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
data_con) (UniqSM ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind]))
-> UniqSM ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall a b. (a -> b) -> a -> b
$ ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
    go Subst
subst (Boxer
UnitBox : [Boxer]
boxers) (Id
src_var : [Id]
src_vars)
      = do { ([Id]
rep_ids2, [CoreBind]
binds) <- Subst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
go Subst
subst [Boxer]
boxers [Id]
src_vars
           ; ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall a. a -> UniqSM a
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
subst (Boxer Subst -> UniqSM ([Id], CoreExpr)
boxer : [Boxer]
boxers) (Id
src_var : [Id]
src_vars)
      = do { ([Id]
rep_ids1, CoreExpr
arg)  <- Subst -> UniqSM ([Id], CoreExpr)
boxer Subst
subst
           ; ([Id]
rep_ids2, [CoreBind]
binds) <- Subst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
go Subst
subst [Boxer]
boxers [Id]
src_vars
           ; ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
forall a. a -> UniqSM a
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 Subst
_ (Boxer
_:[Boxer]
_) [] = String -> SDoc -> UniqSM ([Id], [CoreBind])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"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 [] CoreExpr
con_app
      = CoreExpr -> UniqSM CoreExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
con_app
    mk_rep_app ((Id
wrap_arg, Unboxer
unboxer) : [(Id, Unboxer)]
prs) CoreExpr
con_app
      = do { ([Id]
rep_ids, 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 a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoreExpr
unbox_fn CoreExpr
expr) }


dataConWrapperInlinePragma :: InlinePragma
-- See Note [DataCon wrappers are conlike]
dataConWrapperInlinePragma :: InlinePragma
dataConWrapperInlinePragma =  InlinePragma
alwaysInlineConLikePragma

{- Note [Activation for data constructor wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Activation on a data constructor wrapper allows it to inline only in FinalPhase.
This way rules have a chance to fire 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.

On the other hand, this means that exprIsConApp_maybe must be able to deal
with wrappers so that case-of-constructor is not delayed; see
Note [exprIsConApp_maybe on data constructors with wrappers] for details.

It used to activate in phases 2 (afterInitial) and later, but it makes it
awkward to write a RULE[1] with a constructor on the left: it would work if a
constructor has no wrapper, but whether a constructor has a wrapper depends, for
instance, on the order of type argument of that constructors. Therefore changing
the order of type argument could make previously working RULEs fail.

See also https://gitlab.haskell.org/ghc/ghc/issues/15840 .

Note [DataCon wrappers are conlike]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DataCon workers are clearly ConLike --- they are the “Con” in
“ConLike”, after all --- but what about DataCon wrappers? Should they
be marked ConLike, too?

Yes, absolutely! As described in Note [CONLIKE pragma] in
GHC.Types.Basic, isConLike influences GHC.Core.Utils.exprIsExpandable,
which is used by both RULE matching and the case-of-known-constructor
optimization. It’s crucial that both of those things can see
applications of DataCon wrappers:

  * User-defined RULEs match on wrappers, not workers, so we might
    need to look through an unfolding built from a DataCon wrapper to
    determine if a RULE matches.

  * Likewise, if we have something like
        let x = $WC a b in ... case x of { C y z -> e } ...
    we still want to apply case-of-known-constructor.

Therefore, it’s important that we consider DataCon wrappers conlike.
This is especially true now that we don’t inline DataCon wrappers
until the final simplifier phase; see Note [Activation for data
constructor wrappers].

For further reading, see:
  * Note [Conlike is interesting] in GHC.Core.Op.Simplify.Utils
  * Note [Lone variables] in GHC.Core.Unfold
  * Note [exprIsConApp_maybe on data constructors with wrappers]
    in GHC.Core.SimpleOpt
  * #18012

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 #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 GHC.Core.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 #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].
-}

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

-- | Conjure a fresh local binder.
newLocal :: FastString   -- ^ a string which will form part of the 'Var'\'s name
         -> Scaled Type  -- ^ the type of the 'Var'
         -> UniqSM Var
newLocal :: RuleName -> Scaled Type -> UniqSM Id
newLocal RuleName
name_stem (Scaled Type
w Type
ty) =
    RuleName -> Type -> Type -> UniqSM Id
forall (m :: * -> *).
MonadUnique m =>
RuleName -> Type -> Type -> m Id
mkSysLocalOrCoVarM RuleName
name_stem Type
w Type
ty
         -- We should not have "OrCoVar" here, this is a bug (#17545)


-- | 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
   :: BangOpts
   -> FamInstEnvs
   -> Scaled Type
   -> HsSrcBang
   -> HsImplBang

dataConSrcToImplBang :: BangOpts -> FamInstEnvs -> Scaled Type -> HsSrcBang -> HsImplBang
dataConSrcToImplBang BangOpts
bang_opts FamInstEnvs
fam_envs Scaled Type
arg_ty
                     (HsSrcBang SourceText
ann SrcUnpackedness
unpk SrcStrictness
NoSrcStrict)
  | BangOpts -> Bool
bang_opt_strict_data BangOpts
bang_opts -- StrictData => strict field
  = BangOpts -> FamInstEnvs -> Scaled Type -> HsSrcBang -> HsImplBang
dataConSrcToImplBang BangOpts
bang_opts FamInstEnvs
fam_envs Scaled Type
arg_ty
                  (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
ann SrcUnpackedness
unpk SrcStrictness
SrcStrict)
  | Bool
otherwise -- no StrictData => lazy field
  = HsImplBang
HsLazy

dataConSrcToImplBang BangOpts
_ FamInstEnvs
_ Scaled Type
_ (HsSrcBang SourceText
_ SrcUnpackedness
_ SrcStrictness
SrcLazy)
  = HsImplBang
HsLazy

dataConSrcToImplBang BangOpts
bang_opts FamInstEnvs
fam_envs Scaled Type
arg_ty
                     (HsSrcBang SourceText
_ SrcUnpackedness
unpk_prag SrcStrictness
SrcStrict)
  | HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
arg_ty)
    -- NB: non-newtype data constructors can't have representation-polymorphic fields
    -- so this is OK.
  = HsImplBang
HsLazy  -- For !Int#, say, use HsLazy
            -- See Note [Data con wrappers and unlifted types]

  | let mb_co :: Maybe Reduction
mb_co   = FamInstEnvs -> Type -> Maybe Reduction
topNormaliseType_maybe FamInstEnvs
fam_envs (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
arg_ty)
                     -- Unwrap type families and newtypes
        arg_ty' :: Scaled Type
arg_ty' = case Maybe Reduction
mb_co of
                    { Just Reduction
redn -> Scaled Type -> Type -> Scaled Type
forall a b. Scaled a -> b -> Scaled b
scaledSet Scaled Type
arg_ty (Reduction -> Type
reductionReducedType Reduction
redn)
                    ; Maybe Reduction
Nothing   -> Scaled Type
arg_ty }
  , BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
shouldUnpackArgTy BangOpts
bang_opts SrcUnpackedness
unpk_prag FamInstEnvs
fam_envs Scaled Type
arg_ty'
  = if BangOpts -> Bool
bang_opt_unbox_disable BangOpts
bang_opts
    then Bool -> HsImplBang
HsStrict Bool
True -- Not unpacking because of -O0
                       -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon
    else case Maybe Reduction
mb_co of
           Maybe Reduction
Nothing   -> Maybe Coercion -> HsImplBang
HsUnpack Maybe Coercion
forall a. Maybe a
Nothing
           Just Reduction
redn -> Maybe Coercion -> HsImplBang
HsUnpack (Coercion -> Maybe Coercion
forall a. a -> Maybe a
Just (Coercion -> Maybe Coercion) -> Coercion -> Maybe Coercion
forall a b. (a -> b) -> a -> b
$ Reduction -> Coercion
reductionCoercion Reduction
redn)

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

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

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

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

dataConArgRep Scaled Type
arg_ty (HsUnpack Maybe Coercion
Nothing)
  = Scaled Type -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack Scaled Type
arg_ty

dataConArgRep (Scaled Type
w Type
_) (HsUnpack (Just Coercion
co))
  | let co_rep_ty :: Type
co_rep_ty = Coercion -> Type
coercionRKind Coercion
co
  , ([(Scaled Type, StrictnessMark)]
rep_tys, (Unboxer, Boxer)
wrappers) <- Scaled Type -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
w Type
co_rep_ty)
  = ([(Scaled 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 Coercion
co Type
rep_ty (Unboxer
unbox_rep, Boxer
box_rep)  -- co :: arg_ty ~ rep_ty
  = (Unboxer
unboxer, Boxer
boxer)
  where
    unboxer :: Unboxer
unboxer Id
arg_id = do { Id
rep_id <- RuleName -> Scaled Type -> UniqSM Id
newLocal (String -> RuleName
fsLit String
"cowrap_unbx") (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled (Id -> Type
idMult Id
arg_id) Type
rep_ty)
                        ; ([Id]
rep_ids, 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 a. a -> UniqSM a
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 = (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
Boxer ((Subst -> UniqSM ([Id], CoreExpr)) -> Boxer)
-> (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
forall a b. (a -> b) -> a -> b
$ \ Subst
subst ->
            do { ([Id]
rep_ids, CoreExpr
rep_expr)
                    <- case Boxer
box_rep of
                         Boxer
UnitBox -> do { Id
rep_id <- RuleName -> Scaled Type -> UniqSM Id
newLocal (String -> RuleName
fsLit String
"cowrap_bx") (Type -> Scaled Type
forall a. a -> Scaled a
linear (Type -> Scaled Type) -> Type -> Scaled Type
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
TcType.substTy Subst
subst Type
rep_ty)
                                       ; ([Id], CoreExpr) -> UniqSM ([Id], CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id
rep_id], Id -> CoreExpr
forall b. Id -> Expr b
Var Id
rep_id) }
                         Boxer Subst -> UniqSM ([Id], CoreExpr)
boxer -> Subst -> UniqSM ([Id], CoreExpr)
boxer Subst
subst
               ; let sco :: Coercion
sco = Subst -> Coercion -> Coercion
substCoUnchecked Subst
subst Coercion
co
               ; ([Id], CoreExpr) -> UniqSM ([Id], CoreExpr)
forall a. a -> UniqSM a
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 Id
v = ([Id], CoreExpr -> CoreExpr) -> UniqSM ([Id], CoreExpr -> CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id
v], CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
v) Id
v)

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

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

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

{- Note [UNPACK for sum types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have a data type D, for example:
    data D = D1 [Int] [Bool]
           | D2

and another data type which unpacks a field of type D:
    data U a = MkU {-# UNPACK #-} !D
                   {-# UNPACK #-} !(a,a)
                   {-# UNPACK #-} !D

Then the wrapper and worker for MkU have these types

  -- Wrapper
  $WMkU :: D -> (a,a) -> D -> U a

  -- Worker
  MkU :: (# (# [Int],[Bool] #) | (# #) #)
      -> a
      -> a
      -> (# (# [Int],[Bool] #) | (# #) #)
      -> U a

For each unpacked /sum/-type argument, the worker gets one argument.
But for each unpacked /product/-type argument, the worker gets N
arguments (here two).

Why treat them differently?  See Note [Why sums and products are treated differently].

The wrapper $WMkU looks like this:

  $WMkU :: D -> (a,a) -> D -> U a
  $WMkU x1 y x2
    = case (case x1 of {
              D1 a b -> (# (# a,b #) | #)
              D2     -> (# | (# #) #) }) of { x1_ubx ->
      case y of { (y1, y2) ->
      case (case x2 of {
              D1 a b -> (# (# a,b #) | #)
              D2     -> (# | (# #) #) }) of { x2_ubx ->
      MkU x1_ubx y1 y2 x2_ubx

Notice the nested case needed for sums.

This different treatment for sums and product is implemented in
dataConArgUnpackSum and dataConArgUnpackProduct respectively.

Note [Why sums and products are treated differently]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Can we handle sums like products, with each wrapper argument
occupying multiple argument slots in the worker?  No: for a sum
type the number of argument slots varies, and that's exactly what
unboxed sums are designed for.

Can we handle products like sums, with each wrapper argument occupying
exactly one argument slot (and unboxed tuple) in the worker?  Yes,
we could.  For example
   data P = MkP {-# UNPACK #-} !Q
   data Q = MkQ {-# NOUNPACK #-} !Int
                {-# NOUNPACK #-} Int

Currently could unpack P thus, taking two slots in the worker
   $WMkP :: Q -> P
   $WMkP x = case x of { MkQ a b -> MkP a b }
   MkP :: Int -> Int -> P  -- Worker

We could instead do this (uniformly with sums)

   $WMkP1 :: Q -> P
   $WMkP1 x = case (case x of { MkQ a b -> (# a, b #) }) of ubx_x
              MkP1 ubx_x
   MkP1 :: (# Int, Int #) -> P  -- Worker

The representation of MkP and MkP1 would be identical (a constructor
with two fields).

BUT, with MkP (as with every data constructor) we record its argument
strictness as a bit-vector, actually [StrictnessMark]
   MkP strictness:  SL
This information is used in Core to record which fields are sure to
be evaluated.  (Look for calls to dataConRepStrictness.)  E.g. in Core
    case v of MkP x y -> ....<here x is known to be evald>....

Alas, with MkP1 this information is hidden by the unboxed pair,
In Core there will be an auxiliary case expression to take apart the pair:
    case v of MkP1 xy -> case xy of (# x,y #) -> ...
And now we have no easy way to know that x is evaluated in the "...".

Fixing this might be possible, but it'd be tricky.  So we avoid the
problem entirely by treating sums and products differently here.
-}

dataConArgUnpack
   :: Scaled Type
   ->  ( [(Scaled Type, StrictnessMark)]   -- Rep types
       , (Unboxer, Boxer) )
dataConArgUnpack :: Scaled Type -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack scaledTy :: Scaled Type
scaledTy@(Scaled Type
_ Type
arg_ty)
  | Just (TyCon
tc, [Type]
tc_args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
arg_ty
  = Bool
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (TyCon -> Bool
isNewTyCon TyCon
tc)) (([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
 -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer)))
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
forall a b. (a -> b) -> a -> b
$
    case TyCon -> [DataCon]
tyConDataCons TyCon
tc of
      [DataCon
con] -> Scaled Type
-> [Type]
-> DataCon
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpackProduct Scaled Type
scaledTy [Type]
tc_args DataCon
con
      [DataCon]
cons  -> Scaled Type
-> [Type]
-> [DataCon]
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpackSum Scaled Type
scaledTy [Type]
tc_args [DataCon]
cons
  | Bool
otherwise
  = String
-> SDoc -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dataConArgUnpack" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_ty)
    -- An interface file specified Unpacked, but we couldn't unpack it

dataConArgUnpackProduct
  :: Scaled Type
  -> [Type]
  -> DataCon
  -> ( [(Scaled Type, StrictnessMark)]   -- Rep types
     , (Unboxer, Boxer) )
dataConArgUnpackProduct :: Scaled Type
-> [Type]
-> DataCon
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpackProduct (Scaled Type
arg_mult Type
_) [Type]
tc_args DataCon
con =
  Bool
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
forall a. HasCallStack => Bool -> a -> a
assert ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Id]
dataConExTyCoVars DataCon
con)) (([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
 -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer)))
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
forall a b. (a -> b) -> a -> b
$
    -- Note [Unpacking GADTs and existentials]
  let rep_tys :: [Scaled Type]
rep_tys = (Scaled Type -> Scaled Type) -> [Scaled Type] -> [Scaled Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Scaled Type -> Scaled Type
forall a. Type -> Scaled a -> Scaled a
scaleScaled Type
arg_mult) ([Scaled Type] -> [Scaled Type]) -> [Scaled Type] -> [Scaled Type]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Type] -> [Scaled Type]
dataConInstArgTys DataCon
con [Type]
tc_args
  in ( [Scaled Type]
rep_tys [Scaled Type]
-> [StrictnessMark] -> [(Scaled Type, StrictnessMark)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
con
     , ( \ Id
arg_id ->
         do { [Id]
rep_ids <- (Scaled Type -> UniqSM Id) -> [Scaled Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (RuleName -> Scaled Type -> UniqSM Id
newLocal (String -> RuleName
fsLit String
"unbx")) [Scaled Type]
rep_tys
            ; let r_mult :: Type
r_mult = Id -> Type
idMult Id
arg_id
            ; let rep_ids' :: [Id]
rep_ids' = (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Id -> Id
scaleIdBy Type
r_mult) [Id]
rep_ids
            ; let unbox_fn :: CoreExpr -> CoreExpr
unbox_fn CoreExpr
body
                    = CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
arg_id) Id
arg_id
                               (DataCon -> AltCon
DataAlt DataCon
con) [Id]
rep_ids' CoreExpr
body
            ; ([Id], CoreExpr -> CoreExpr) -> UniqSM ([Id], CoreExpr -> CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
rep_ids, CoreExpr -> CoreExpr
unbox_fn) }
       , (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
Boxer ((Subst -> UniqSM ([Id], CoreExpr)) -> Boxer)
-> (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
forall a b. (a -> b) -> a -> b
$ \ Subst
subst ->
         do { [Id]
rep_ids <- (Scaled Type -> UniqSM Id) -> [Scaled Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (RuleName -> Scaled Type -> UniqSM Id
newLocal (String -> RuleName
fsLit String
"bx") (Scaled Type -> UniqSM Id)
-> (Scaled Type -> Scaled Type) -> Scaled Type -> UniqSM Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Subst -> Scaled Type -> Scaled Type
Subst -> Scaled Type -> Scaled Type
TcType.substScaledTyUnchecked Subst
subst) [Scaled Type]
rep_tys
            ; ([Id], CoreExpr) -> UniqSM ([Id], CoreExpr)
forall a. a -> UniqSM a
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` (Subst -> [Type] -> [Type]
substTysUnchecked Subst
subst [Type]
tc_args)
                               CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
`mkVarApps` [Id]
rep_ids ) } ) )

dataConArgUnpackSum
  :: Scaled Type
  -> [Type]
  -> [DataCon]
  -> ( [(Scaled Type, StrictnessMark)]   -- Rep types
     , (Unboxer, Boxer) )
dataConArgUnpackSum :: Scaled Type
-> [Type]
-> [DataCon]
-> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpackSum (Scaled Type
arg_mult Type
arg_ty) [Type]
tc_args [DataCon]
cons =
  ( [ (Scaled Type
sum_ty, StrictnessMark
MarkedStrict) ] -- The idea: Unpacked variant will
                               -- be one field only, and the type of the
                               -- field will be an unboxed sum.
  , ( Unboxer
unboxer, Boxer
boxer ) )
  where
    !ubx_sum_arity :: Int
ubx_sum_arity = [DataCon] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataCon]
cons
    src_tys :: [[Type]]
src_tys = (DataCon -> [Type]) -> [DataCon] -> [[Type]]
forall a b. (a -> b) -> [a] -> [b]
map (\DataCon
con -> (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing ([Scaled Type] -> [Type]) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Type] -> [Scaled Type]
dataConInstArgTys DataCon
con [Type]
tc_args) [DataCon]
cons
    sum_alt_tys :: [Type]
sum_alt_tys = ([Type] -> Type) -> [[Type]] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map [Type] -> Type
mkUbxSumAltTy [[Type]]
src_tys
    sum_ty_unscaled :: Type
sum_ty_unscaled = [Type] -> Type
mkSumTy [Type]
sum_alt_tys
    sum_ty :: Scaled Type
sum_ty = Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
arg_mult Type
sum_ty_unscaled
    newLocal' :: RuleName -> Type -> UniqSM Id
newLocal' RuleName
fs = RuleName -> Scaled Type -> UniqSM Id
newLocal RuleName
fs (Scaled Type -> UniqSM Id)
-> (Type -> Scaled Type) -> Type -> UniqSM Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
arg_mult

    -- See Note [UNPACK for sum types]
    unboxer :: Unboxer
    unboxer :: Unboxer
unboxer Id
arg_id = do
      [[Id]]
con_arg_binders <- ([Type] -> UniqSM [Id]) -> [[Type]] -> UniqSM [[Id]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Type -> UniqSM Id) -> [Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (RuleName -> Type -> UniqSM Id
newLocal' (String -> RuleName
fsLit String
"unbx"))) [[Type]]
src_tys
      Id
ubx_sum_bndr <- RuleName -> Scaled Type -> UniqSM Id
newLocal (String -> RuleName
fsLit String
"unbx") Scaled Type
sum_ty

      let
        mk_ubx_sum_alt :: Int -> DataCon -> [Var] -> CoreAlt
        mk_ubx_sum_alt :: Int -> DataCon -> [Id] -> CoreAlt
mk_ubx_sum_alt Int
alt DataCon
con [Id
bndr] = AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
con) [Id
bndr]
            (Int -> Int -> [Type] -> CoreExpr -> CoreExpr
mkCoreUnboxedSum Int
ubx_sum_arity Int
alt [Type]
sum_alt_tys (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
bndr))

        mk_ubx_sum_alt Int
alt DataCon
con [Id]
bndrs =
          let tuple :: CoreExpr
tuple = [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
bndrs)
           in AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
con) [Id]
bndrs (Int -> Int -> [Type] -> CoreExpr -> CoreExpr
mkCoreUnboxedSum Int
ubx_sum_arity Int
alt [Type]
sum_alt_tys CoreExpr
tuple )

        ubx_sum :: CoreExpr
        ubx_sum :: CoreExpr
ubx_sum =
          let alts :: [CoreAlt]
alts = (Int -> DataCon -> [Id] -> CoreAlt)
-> [Int] -> [DataCon] -> [[Id]] -> [CoreAlt]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> DataCon -> [Id] -> CoreAlt
mk_ubx_sum_alt [ Int
1 .. ] [DataCon]
cons [[Id]]
con_arg_binders
           in CoreExpr -> Id -> Type -> [CoreAlt] -> 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 ([CoreAlt] -> Type
coreAltsType [CoreAlt]
alts) [CoreAlt]
alts

        unbox_fn :: CoreExpr -> CoreExpr
        unbox_fn :: CoreExpr -> CoreExpr
unbox_fn CoreExpr
body =
          CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase CoreExpr
ubx_sum Id
ubx_sum_bndr AltCon
DEFAULT [] CoreExpr
body

      ([Id], CoreExpr -> CoreExpr) -> UniqSM ([Id], CoreExpr -> CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id
ubx_sum_bndr], CoreExpr -> CoreExpr
unbox_fn)

    boxer :: Boxer
    boxer :: Boxer
boxer = (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
Boxer ((Subst -> UniqSM ([Id], CoreExpr)) -> Boxer)
-> (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
forall a b. (a -> b) -> a -> b
$ \ Subst
subst -> do
              Id
unboxed_field_id <- RuleName -> Type -> UniqSM Id
newLocal' (String -> RuleName
fsLit String
"bx") (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
TcType.substTy Subst
subst Type
sum_ty_unscaled)
              [Id]
tuple_bndrs <- (Type -> UniqSM Id) -> [Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (RuleName -> Type -> UniqSM Id
newLocal' (String -> RuleName
fsLit String
"bx") (Type -> UniqSM Id) -> (Type -> Type) -> Type -> UniqSM Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
TcType.substTy Subst
subst) [Type]
sum_alt_tys

              let tc_args' :: [Type]
tc_args' = HasDebugCallStack => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTys Subst
subst [Type]
tc_args
                  arg_ty' :: Type
arg_ty' = HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
arg_ty

              [[Id]]
con_arg_binders <-
                ([Type] -> UniqSM [Id]) -> [[Type]] -> UniqSM [[Id]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Type -> UniqSM Id) -> [Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (RuleName -> Type -> UniqSM Id
newLocal' (String -> RuleName
fsLit String
"bx")) ([Type] -> UniqSM [Id])
-> ([Type] -> [Type]) -> [Type] -> UniqSM [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
TcType.substTy Subst
subst)) [[Type]]
src_tys

              let mk_sum_alt :: Int -> DataCon -> Var -> [Var] -> CoreAlt
                  mk_sum_alt :: Int -> DataCon -> Id -> [Id] -> CoreAlt
mk_sum_alt Int
alt DataCon
con Id
_ [Id
datacon_bndr] =
                    ( AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Int -> Int -> DataCon
sumDataCon Int
alt Int
ubx_sum_arity)) [Id
datacon_bndr]
                      (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
con) CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps`  [Type]
tc_args'
                                              CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
`mkVarApps` [Id
datacon_bndr] ))

                  mk_sum_alt Int
alt DataCon
con Id
tuple_bndr [Id]
datacon_bndrs =
                    ( AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Int -> Int -> DataCon
sumDataCon Int
alt Int
ubx_sum_arity)) [Id
tuple_bndr] (
                      CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
tuple_bndr) Id
tuple_bndr Type
arg_ty'
                        [ AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
datacon_bndrs))) [Id]
datacon_bndrs
                            (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
con) CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps`  [Type]
tc_args'
                                                    CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
`mkVarApps` [Id]
datacon_bndrs ) ] ))

              ([Id], CoreExpr) -> UniqSM ([Id], CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [Id
unboxed_field_id],
                       CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
unboxed_field_id) Id
unboxed_field_id Type
arg_ty'
                            ((Int -> DataCon -> Id -> [Id] -> CoreAlt)
-> [Int] -> [DataCon] -> [Id] -> [[Id]] -> [CoreAlt]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4 Int -> DataCon -> Id -> [Id] -> CoreAlt
mk_sum_alt [ Int
1 .. ] [DataCon]
cons [Id]
tuple_bndrs [[Id]]
con_arg_binders) )

-- | Every alternative of an unboxed sum has exactly one field, and we use
-- unboxed tuples when we need more than one field. This generates an unboxed
-- tuple when necessary, to be used in unboxed sum alts.
mkUbxSumAltTy :: [Type] -> Type
mkUbxSumAltTy :: [Type] -> Type
mkUbxSumAltTy [Type
ty] = Type
ty
mkUbxSumAltTy [Type]
tys  = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type]
tys

shouldUnpackArgTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
-- True if we ought to 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!
shouldUnpackArgTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
shouldUnpackArgTy BangOpts
bang_opts SrcUnpackedness
prag FamInstEnvs
fam_envs Scaled Type
arg_ty
  | Just [DataCon]
data_cons <- Type -> Maybe [DataCon]
unpackable_type_datacons (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
arg_ty)
  , (DataCon -> Bool) -> [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all DataCon -> Bool
ok_con [DataCon]
data_cons                -- Returns True only if we can't get a
                                        -- loop involving these data cons
  , SrcUnpackedness -> Scaled Type -> [DataCon] -> Bool
should_unpack SrcUnpackedness
prag Scaled Type
arg_ty [DataCon]
data_cons -- ...hence the call to dataConArgUnpack in
                                        --    should_unpack won't loop
       -- See Wrinkle (W1b) of Note [Recursive unboxing] for this loopy stuff
  = Bool
True

  | Bool
otherwise
  = Bool
False
  where
    ok_con :: DataCon -> Bool      -- True <=> OK to unpack
    ok_con :: DataCon -> Bool
ok_con DataCon
top_con                 -- False <=> not safe
      = NameSet -> DataCon -> Bool
ok_args NameSet
emptyNameSet DataCon
top_con
       where
         top_con_name :: Name
top_con_name = DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
top_con

         ok_args :: NameSet -> DataCon -> Bool
ok_args NameSet
dcs DataCon
con
           = ((Scaled Type, HsSrcBang) -> Bool)
-> [(Scaled Type, HsSrcBang)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (NameSet -> (Scaled Type, HsSrcBang) -> Bool
ok_arg NameSet
dcs) ([(Scaled Type, HsSrcBang)] -> Bool)
-> [(Scaled Type, HsSrcBang)] -> Bool
forall a b. (a -> b) -> a -> b
$
             (DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
con [Scaled Type] -> [HsSrcBang] -> [(Scaled 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

         ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool
         ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool
ok_arg NameSet
dcs (Scaled Type
_ Type
ty, HsSrcBang SourceText
_ SrcUnpackedness
unpack_prag SrcStrictness
str_prag)
           | SrcStrictness -> Bool
strict_field SrcStrictness
str_prag
           , Just [DataCon]
data_cons <- Type -> Maybe [DataCon]
unpackable_type_datacons (FamInstEnvs -> Type -> Type
topNormaliseType FamInstEnvs
fam_envs Type
ty)
           , SrcUnpackedness -> [DataCon] -> Bool
should_unpack_conservative SrcUnpackedness
unpack_prag [DataCon]
data_cons  -- Wrinkle (W3)
           = (DataCon -> Bool) -> [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (NameSet -> DataCon -> Bool
ok_rec_con NameSet
dcs) [DataCon]
data_cons                    --  of Note [Recursive unboxing]
           | Bool
otherwise
           = Bool
True        -- NB True here, in contrast to False at top level

         -- See Note [Recursive unboxing]
         --   * Do not look at the HsImplBangs to `con`; see Wrinkle (W1a)
         --   * For the "at the root" comments see Wrinkle (W2)
         ok_rec_con :: NameSet -> DataCon -> Bool
ok_rec_con NameSet
dcs DataCon
con
           | Name
dc_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
top_con_name   = Bool
False  -- Recursion at the root
           | Name
dc_name Name -> NameSet -> Bool
`elemNameSet` NameSet
dcs = Bool
True   -- Not at the root
           | Bool
otherwise                 = NameSet -> DataCon -> Bool
ok_args (NameSet
dcs NameSet -> Name -> NameSet
`extendNameSet` Name
dc_name) DataCon
con
           where
             dc_name :: Name
dc_name = DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
con

    strict_field :: SrcStrictness -> Bool
    -- True <=> strict field
    strict_field :: SrcStrictness -> Bool
strict_field SrcStrictness
NoSrcStrict = BangOpts -> Bool
bang_opt_strict_data BangOpts
bang_opts
    strict_field SrcStrictness
SrcStrict   = Bool
True
    strict_field SrcStrictness
SrcLazy     = Bool
False

    -- Determine whether we ought to unpack a field,
    -- based on user annotations if present.
    -- A conservative version of should_unpack that doesn't look at how
    -- many fields the field would unpack to... because that leads to a loop.
    -- "Conservative" = err on the side of saying "yes".
    should_unpack_conservative :: SrcUnpackedness -> [DataCon] -> Bool
    should_unpack_conservative :: SrcUnpackedness -> [DataCon] -> Bool
should_unpack_conservative SrcUnpackedness
SrcNoUnpack [DataCon]
_   = Bool
False  -- {-# NOUNPACK #-}
    should_unpack_conservative SrcUnpackedness
SrcUnpack   [DataCon]
_   = Bool
True   -- {-# NOUNPACK #-}
    should_unpack_conservative SrcUnpackedness
NoSrcUnpack [DataCon]
dcs = Bool -> Bool
not ([DataCon] -> Bool
is_sum [DataCon]
dcs)
        -- is_sum: we never unpack sums without a pragma; otherwise be conservative

    -- Determine whether we ought to unpack a field,
    -- based on user annotations if present, and heuristics if not.
    should_unpack :: SrcUnpackedness -> Scaled Type -> [DataCon] -> Bool
    should_unpack :: SrcUnpackedness -> Scaled Type -> [DataCon] -> Bool
should_unpack SrcUnpackedness
prag Scaled Type
arg_ty [DataCon]
data_cons =
      case SrcUnpackedness
prag of
        SrcUnpackedness
SrcNoUnpack -> Bool
False -- {-# NOUNPACK #-}
        SrcUnpackedness
SrcUnpack   -> Bool
True  -- {-# UNPACK #-}
        SrcUnpackedness
NoSrcUnpack -- No explicit unpack pragma, so use heuristics
          | [DataCon] -> Bool
is_sum [DataCon]
data_cons
          -> Bool
False -- Don't unpack sum types automatically, but they can
                   -- be unpacked with an explicit source UNPACK.
          | Bool
otherwise   -- Wrinkle (W4) of Note [Recursive unboxing]
          -> BangOpts -> Bool
bang_opt_unbox_strict BangOpts
bang_opts
             Bool -> Bool -> Bool
|| (BangOpts -> Bool
bang_opt_unbox_small BangOpts
bang_opts
                 Bool -> Bool -> Bool
&& [(Scaled Type, StrictnessMark)]
rep_tys [(Scaled Type, StrictnessMark)] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtMost` Int
1)  -- See Note [Unpack one-wide fields]
      where
        ([(Scaled Type, StrictnessMark)]
rep_tys, (Unboxer, Boxer)
_) = Scaled Type -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
dataConArgUnpack Scaled Type
arg_ty

    is_sum :: [DataCon] -> Bool
    -- We never unpack sum types automatically
    -- (Product types, we do. Empty types are weeded out by unpackable_type_datacons.)
    is_sum :: [DataCon] -> Bool
is_sum (DataCon
_:DataCon
_:[DataCon]
_) = Bool
True
    is_sum [DataCon]
_       = Bool
False

-- Given a type already assumed to have been normalized by topNormaliseType,
-- unpackable_type_datacons ty = Just datacons
-- iff ty is of the form
--     T ty1 .. tyn
-- and T is an algebraic data type (not newtype), in which no data
-- constructors have existentials, and datacons is the list of data
-- constructors of T.
unpackable_type_datacons :: Type -> Maybe [DataCon]
unpackable_type_datacons :: Type -> Maybe [DataCon]
unpackable_type_datacons Type
ty
  | Just (TyCon
tc, [Type]
_) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
  , Bool -> Bool
not (TyCon -> Bool
isNewTyCon TyCon
tc)  -- Even though `ty` has been normalised, it could still
                         -- be a /recursive/ newtype, so we must check for that
  , Just [DataCon]
cons <- TyCon -> Maybe [DataCon]
tyConDataCons_maybe TyCon
tc
  , Bool -> Bool
not ([DataCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
cons)      -- Don't upack nullary sums; no need.
                         -- They already take zero bits
  , (DataCon -> Bool) -> [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Id] -> Bool) -> (DataCon -> [Id]) -> DataCon -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> [Id]
dataConExTyCoVars) [DataCon]
cons
  = [DataCon] -> Maybe [DataCon]
forall a. a -> Maybe a
Just [DataCon]
cons -- See Note [Unpacking GADTs and existentials]
  | 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 #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.

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

Wrinkles:

(W1a) We have to be careful that the compiler doesn't go into a loop!
      First, we must not look at the HsImplBang decisions of data constructors
      in the same mutually recursive group.  E.g.
         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.
      (We could detect when we leave the group, and /then/ we can rely on
      HsImplBangs; but that requires more plumbing.)

(W1b) Here is another way the compiler might go into a loop (test T23307b):
         data data T = MkT !S Int
         data S = MkS !T
     Suppose we call `shouldUnpackArgTy` on the !S arg of `T`.  In `should_unpack`
     we ask if the number of fields that `MkS` unpacks to is small enough
     (via rep_tys `lengthAtMost` 1).  But how many field /does/ `MkS` unpack
     to?  Well it depends on the unpacking decision we make for `MkS`, which
     in turn depends on `MkT`, which we are busy deciding. Black holes beckon.

     So we /first/ call `ok_con` on `MkS` (and `ok_con` is conservative;
     see `should_unpack_conservative`), and only /then/ call `should_unpack`.
     Tricky!

(W2) As #23307 shows,  we /do/ want to unpack the second arg of the Yes
     data constructor in this example, despite the recursion in List:
       data Stream a   = Cons a !(Stream a)
       data Unconsed a = Unconsed a !(Stream a)
       data MUnconsed a = No | Yes {-# UNPACK #-} !(Unconsed a)
     When looking at
       {-# UNPACK #-} (Unconsed a)
     we can take Unconsed apart, but then get into a loop with Stream.
     That's fine: we can still take Unconsed apart.  It's only if we
     have a loop /at the root/ that we must not unpack.

(W3) Moreover (W2) can apply even if there is a recursive loop:
       data List a = Nil | Cons {-# UNPACK #-} !(Unconsed a)
       data Unconsed a = Unconsed a !(List a)
     Here there is mutual recursion between `Unconsed` and `List`; and yet
     we can unpack the field of `Cons` because we will not unpack the second
     field of `Unconsed`: we never unpack a sum type without an explicit
     pragma (see should_unpack).

(W4) Consider
        data T = MkT !Wombat
        data Wombat = MkW {-# UNPACK #-} !S Int
        data S = MkS {-# NOUNPACK #-} !Wombat Int
     Suppose we are deciding whether to unpack the first field of MkT, by
     calling (shouldUnpackArgTy Wombat).  Then we'll try to unpack the !S field
     of MkW, and be stopped by the {-# NOUNPACK #-}, and all is fine; we can
     unpack MkT.

     If that NOUNPACK had been a UNPACK, though, we'd get a loop, and would
     decide not to unpack the Wombat field of MkT.

     But what if there was no pragma in `data S`?  Then we /still/ decide not
     to unpack the Wombat field of MkT (at least when auto-unpacking is on),
     because we don't know for sure which decision will be taken for the
     Wombat field of MkS.

     TL;DR when there is no pragma, behave as if there was a UNPACK, at least
     when auto-unpacking is on.  See `should_unpack` in `shouldUnpackArgTy`.


************************************************************************
*                                                                      *
        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 [Type]
args CoreExpr
result_expr
  = Bool -> CoreExpr -> CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert (TyCon -> Bool
isNewTyCon TyCon
tycon) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
    HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
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 splitting operation (cf, GHC.Tc.Gen.Pat.tcConPat).

unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody TyCon
tycon [Type]
args CoreExpr
result_expr
  = Bool -> CoreExpr -> CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert (TyCon -> Bool
isNewTyCon TyCon
tycon) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
    HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
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 [Type]
args CoreExpr
body
  | Just CoAxiom Unbranched
co_con <- TyCon -> Maybe (CoAxiom Unbranched)
tyConFamilyCoercion_maybe TyCon
tycon
  = HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
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

{-
************************************************************************
*                                                                      *
* Foreign calls
*                                                                      *
************************************************************************
-}

-- 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 :: Unique -> ForeignCall -> Type -> Id
mkFCallId :: Unique -> ForeignCall -> Type -> Id
mkFCallId Unique
uniq ForeignCall
fcall Type
ty
  = Bool -> Id -> Id
forall a. HasCallStack => Bool -> a -> a
assert (Type -> Bool
noFreeVarsOfType Type
ty) (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
    -- 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 = SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (ForeignCall -> SDoc
forall a. Outputable a => a -> SDoc
ppr ForeignCall
fcall SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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 -> RuleName -> Name
mkFCallName Unique
uniq (String -> RuleName
mkFastString String
occ_str)

    info :: IdInfo
info = IdInfo
noCafIdInfo
           IdInfo -> Int -> IdInfo
`setArityInfo`  Int
arity
           IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` DmdSig
strict_sig
           IdInfo -> CprSig -> IdInfo
`setCprSigInfo` CprSig
topCprSig

    ([PiTyVarBinder]
bndrs, Type
_) = Type -> ([PiTyVarBinder], Type)
tcSplitPiTys Type
ty
    arity :: Int
arity      = (PiTyVarBinder -> Bool) -> [PiTyVarBinder] -> Int
forall a. (a -> Bool) -> [a] -> Int
count PiTyVarBinder -> Bool
isAnonPiTyBinder [PiTyVarBinder]
bndrs
    strict_sig :: DmdSig
strict_sig = Int -> Divergence -> DmdSig
mkVanillaDmdSig Int
arity Divergence
topDiv
    -- 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 #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 GHC.Types.Id
-}

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

mkDictFunId :: Name -> [Id] -> [Type] -> Class -> [Type] -> Id
mkDictFunId Name
dfun_name [Id]
tvs [Type]
theta Class
clas [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] -> Type -> Type
TcType.tcMkDFunSigmaTy [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. Alternatively, we could add the definitions to mi_decls of ghcPrimIface
but it's not clear if this would be simpler.

coercionToken# is not listed in ghcPrimIds, since its type uses (~#)
which is not supposed to be used in expressions (GHC throws an assertion
failure when trying.)
-}

nullAddrName, seqName,
   realWorldName, voidPrimIdName, coercionTokenName,
   coerceName, proxyName,
   leftSectionName, rightSectionName :: Name
nullAddrName :: Name
nullAddrName      = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit String
"nullAddr#")      Unique
nullAddrIdKey      Id
nullAddrId
seqName :: Name
seqName           = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit String
"seq")            Unique
seqIdKey           Id
seqId
realWorldName :: Name
realWorldName     = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit String
"realWorld#")     Unique
realWorldPrimIdKey Id
realWorldPrimId
voidPrimIdName :: Name
voidPrimIdName    = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit String
"void#")          Unique
voidPrimIdKey      Id
voidPrimId
coercionTokenName :: Name
coercionTokenName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit String
"coercionToken#") Unique
coercionTokenIdKey Id
coercionTokenId
coerceName :: Name
coerceName        = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit String
"coerce")         Unique
coerceKey          Id
coerceId
proxyName :: Name
proxyName         = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit String
"proxy#")         Unique
proxyHashKey       Id
proxyHashId
leftSectionName :: Name
leftSectionName   = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit String
"leftSection")    Unique
leftSectionKey     Id
leftSectionId
rightSectionName :: Name
rightSectionName  = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM  (String -> RuleName
fsLit String
"rightSection")   Unique
rightSectionKey    Id
rightSectionId

-- Names listed in magicIds; see Note [magicIds]
lazyIdName, oneShotName, nospecIdName :: Name
lazyIdName :: Name
lazyIdName        = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_MAGIC (String -> RuleName
fsLit String
"lazy")           Unique
lazyIdKey          Id
lazyId
oneShotName :: Name
oneShotName       = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_MAGIC (String -> RuleName
fsLit String
"oneShot")        Unique
oneShotKey         Id
oneShotId
nospecIdName :: Name
nospecIdName      = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_MAGIC (String -> RuleName
fsLit String
"nospec")         Unique
nospecIdKey        Id
nospecId

------------------------------------------------
proxyHashId :: Id
proxyHashId :: Id
proxyHashId
  = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
proxyName Type
ty
       (IdInfo
noCafIdInfo IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
evaldUnfolding) -- Note [evaldUnfoldings]
  where
    -- proxy# :: forall {k} (a:k). Proxy# k a
    --
    -- The visibility of the `k` binder is Inferred to match the type of the
    -- Proxy data constructor (#16293).
    [Id
kv,Id
tv] = Type -> (Type -> [Type]) -> [Id]
mkTemplateKiTyVar Type
liftedTypeKind (\Type
x -> [Type
x])
    kv_ty :: Type
kv_ty   = Id -> Type
mkTyVarTy Id
kv
    tv_ty :: Type
tv_ty   = Id -> Type
mkTyVarTy Id
tv
    ty :: Type
ty      = Id -> Type -> Type
mkInfForAllTy Id
kv (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Id -> Type -> Type
mkSpecForAllTy Id
tv (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
mkProxyPrimTy Type
kv_ty Type
tv_ty

------------------------------------------------
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)

------------------------------------------------
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
                       IdInfo -> Int -> IdInfo
`setArityInfo`      Int
arity

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

    -- seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b
    ty :: Type
ty  =
      Id -> Type -> Type
mkInfForAllTy Id
runtimeRep2TyVar
      (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar, Id
openBetaTyVar]
      (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
alphaTy (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
openBetaTy Type
openBetaTy)

    [Id
x,Id
y] = [Type] -> [Id]
mkTemplateLocals [Type
alphaTy, Type
openBetaTy]
    rhs :: CoreExpr
rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams ([Id
runtimeRep2TyVar, Id
alphaTyVar, Id
openBetaTyVar, Id
x, Id
y]) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
          CoreExpr -> Id -> Type -> [CoreAlt] -> 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
openBetaTy [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y)]

    arity :: Int
arity = Int
2

------------------------------------------------
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
    ty :: Type
ty  = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
alphaTy Type
alphaTy)

------------------------------------------------
noinlineIdName, noinlineConstraintIdName :: Name
noinlineIdName :: Name
noinlineIdName           = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_MAGIC (String -> RuleName
fsLit String
"noinline")
                                           Unique
noinlineIdKey Id
noinlineId
noinlineConstraintIdName :: Name
noinlineConstraintIdName = Module -> RuleName -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_MAGIC (String -> RuleName
fsLit String
"noinlineConstraint")
                                           Unique
noinlineConstraintIdKey Id
noinlineConstraintId

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
    ty :: Type
ty  = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
          HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
alphaTy Type
alphaTy

noinlineConstraintId :: Id -- See Note [noinlineId magic]
noinlineConstraintId :: Id
noinlineConstraintId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
noinlineConstraintIdName Type
ty IdInfo
info
  where
    info :: IdInfo
info = IdInfo
noCafIdInfo
    ty :: Type
ty   = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaConstraintTyVar] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
           HasDebugCallStack => FunTyFlag -> Type -> Type -> Type -> Type
FunTyFlag -> Type -> Type -> Type -> Type
mkFunTy FunTyFlag
visArgConstraintLike Type
ManyTy Type
alphaTy Type
alphaConstraintTy

------------------------------------------------
nospecId :: Id -- See Note [nospecId magic]
nospecId :: Id
nospecId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
nospecIdName Type
ty IdInfo
info
  where
    info :: IdInfo
info = IdInfo
noCafIdInfo
    ty :: Type
ty  = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany 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
                       IdInfo -> Int -> IdInfo
`setArityInfo`      Int
arity
    ty :: Type
ty  = [Id] -> Type -> Type
mkInfForAllTys  [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar ] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
          [Id] -> Type -> Type
mkSpecForAllTys [ Id
openAlphaTyVar, Id
openBetaTyVar ]      (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
          HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
fun_ty Type
fun_ty
    fun_ty :: Type
fun_ty = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
openAlphaTy Type
openBetaTy
    [Id
body, 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'
    arity :: Int
arity = Int
2

----------------------------------------------------------------------
{- Note [Wired-in Ids for rebindable syntax]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The functions leftSectionId, rightSectionId are
wired in here ONLY because they are used in a representation-polymorphic way
by the rebindable syntax mechanism. See GHC.Rename.Expr
Note [Handling overloaded and rebindable constructs].

Alas, we can't currently give Haskell definitions for
representation-polymorphic functions.

They have Compulsory unfoldings, so that the representation polymorphism
does not linger for long.
-}

-- See Note [Left and right sections] in GHC.Rename.Expr
-- See Note [Wired-in Ids for rebindable syntax]
--   leftSection :: forall r1 r2 n (a::TYPE r1) (b::TYPE r2).
--                  (a %n-> b) -> a %n-> b
--   leftSection f x = f x
-- Important that it is eta-expanded, so that (leftSection undefined `seq` ())
--   is () and not undefined
-- Important that is is multiplicity-polymorphic (test linear/should_compile/OldList)
leftSectionId :: Id
leftSectionId :: Id
leftSectionId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
leftSectionName 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
                       IdInfo -> Int -> IdInfo
`setArityInfo`      Int
arity
    ty :: Type
ty  = [Id] -> Type -> Type
mkInfForAllTys  [Id
runtimeRep1TyVar,Id
runtimeRep2TyVar, Id
multiplicityTyVar1] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
          [Id] -> Type -> Type
mkSpecForAllTys [Id
openAlphaTyVar,  Id
openBetaTyVar]    (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
          HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body
    [Id
f,Id
x] = [Type] -> [Id]
mkTemplateLocals [HasDebugCallStack => Type -> Type -> Type -> Type
Type -> Type -> Type -> Type
mkVisFunTy Type
mult Type
openAlphaTy Type
openBetaTy, Type
openAlphaTy]

    mult :: Type
mult = Id -> Type
mkTyVarTy Id
multiplicityTyVar1 :: Mult
    xmult :: Id
xmult = Id -> Type -> Id
setIdMult Id
x Type
mult

    rhs :: CoreExpr
rhs  = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar, Id
multiplicityTyVar1
                  , Id
openAlphaTyVar,   Id
openBetaTyVar   ] CoreExpr
body
    body :: CoreExpr
body = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
f,Id
xmult] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
f) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
xmult)
    arity :: Int
arity = Int
2

-- See Note [Left and right sections] in GHC.Rename.Expr
-- See Note [Wired-in Ids for rebindable syntax]
--   rightSection :: forall r1 r2 r3 n1 n2 (a::TYPE r1) (b::TYPE r2) (c::TYPE r3).
--                   (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c
--   rightSection f y x = f x y
-- Again, multiplicity polymorphism is important
rightSectionId :: Id
rightSectionId :: Id
rightSectionId = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
rightSectionName 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
                       IdInfo -> Int -> IdInfo
`setArityInfo`      Int
arity
    ty :: Type
ty  = [Id] -> Type -> Type
mkInfForAllTys  [Id
runtimeRep1TyVar,Id
runtimeRep2TyVar,Id
runtimeRep3TyVar
                          , Id
multiplicityTyVar1, Id
multiplicityTyVar2 ] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
          [Id] -> Type -> Type
mkSpecForAllTys [Id
openAlphaTyVar,  Id
openBetaTyVar,   Id
openGammaTyVar ]  (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
          HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body
    mult1 :: Type
mult1 = Id -> Type
mkTyVarTy Id
multiplicityTyVar1
    mult2 :: Type
mult2 = Id -> Type
mkTyVarTy Id
multiplicityTyVar2

    [Id
f,Id
x,Id
y] = [Type] -> [Id]
mkTemplateLocals [ [Scaled Type] -> Type -> Type
HasDebugCallStack => [Scaled Type] -> Type -> Type
mkScaledFunTys [ Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
mult1 Type
openAlphaTy
                                                , Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
mult2 Type
openBetaTy ] Type
openGammaTy
                               , Type
openAlphaTy, Type
openBetaTy ]
    xmult :: Id
xmult = Id -> Type -> Id
setIdMult Id
x Type
mult1
    ymult :: Id
ymult = Id -> Type -> Id
setIdMult Id
y Type
mult2
    rhs :: CoreExpr
rhs  = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar, Id
runtimeRep3TyVar
                  , Id
multiplicityTyVar1, Id
multiplicityTyVar2
                  , Id
openAlphaTyVar,   Id
openBetaTyVar,    Id
openGammaTyVar ] CoreExpr
body
    body :: CoreExpr
body = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
f,Id
ymult,Id
xmult] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
f) [Id
xmult,Id
ymult]
    arity :: Int
arity = Int
3

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

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
                       IdInfo -> Int -> IdInfo
`setArityInfo`      Int
2
    eqRTy :: Type
eqRTy     = TyCon -> [Type] -> Type
mkTyConApp TyCon
coercibleTyCon  [ Type
tYPE_r,         Type
a, Type
b ]
    eqRPrimTy :: Type
eqRPrimTy = TyCon -> [Type] -> Type
mkTyConApp TyCon
eqReprPrimTyCon [ Type
tYPE_r, Type
tYPE_r, Type
a, Type
b ]
    ty :: Type
ty        = [InvisTVBinder] -> Type -> Type
mkInvisForAllTys [ Id -> Specificity -> InvisTVBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
rv Specificity
InferredSpec
                                 , Id -> Specificity -> InvisTVBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
av Specificity
SpecifiedSpec
                                 , Id -> Specificity -> InvisTVBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
bv Specificity
SpecifiedSpec ] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkInvisFunTy Type
eqRTy (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
a Type
b

    bndrs :: [Id]
bndrs@[Id
rv,Id
av,Id
bv] = Type -> (Type -> [Type]) -> [Id]
mkTemplateKiTyVar Type
runtimeRepTy
                        (\Type
r -> [Type -> Type
mkTYPEapp Type
r, Type -> Type
mkTYPEapp Type
r])

    [Type
r, Type
a, Type
b] = [Id] -> [Type]
mkTyVarTys [Id]
bndrs
    tYPE_r :: Type
tYPE_r    = Type -> Type
mkTYPEapp Type
r

    [Id
eqR,Id
x,Id
eq] = [Type] -> [Id]
mkTemplateLocals [Type
eqRTy, Type
a, Type
eqRPrimTy]
    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
eqR, Id
x]) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
          CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
eqR) (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
eqRTy) Type
b ([CoreAlt] -> CoreExpr) -> [CoreAlt] -> CoreExpr
forall a b. (a -> b) -> a -> b
$
          [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (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 [seqId magic]
~~~~~~~~~~~~~~~~~~
'GHC.Prim.seq' is special in several ways.

a) Its fixity is set in GHC.Iface.Load.ghcPrimIface

b) It has quite a bit of desugaring magic.
   See GHC.HsToCore.Utils Note [Desugaring seq] (1) and (2) and (3)

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

Historical note:
    In GHC.Tc.Gen.Expr we used to need a special typing rule for 'seq', to handle calls
    whose second argument had an unboxed type, e.g.  x `seq` 3#

    However, with representation polymorphism we can now give seq the type
    seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b
    which handles this case without special treatment in the typechecker.

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 GHC.Core.Opt.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 (b)
    for saturated application of 'seq' would turn the LHS into
    a case expression!

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

See also: Note [User-defined RULES for seq] in GHC.Core.Opt.Simplify.


Note [lazyId magic]
~~~~~~~~~~~~~~~~~~~
lazy :: forall a. a -> a

'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
  #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.Magic.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 #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' is used to make sure that a function f is never inlined,
e.g., as in 'noinline f x'.  We won't inline f because we never inline
lone variables (see Note [Lone variables] in GHC.Core.Unfold

You might think that we could implement noinline like this:
   {-# NOINLINE #-}
   noinline :: forall a. a -> a
   noinline x = x

But actually we give 'noinline' a wired-in name for three distinct reasons:

1. We don't want to leave a (useless) call to noinline in the final program,
   to be executed at runtime. So we have a little bit of magic to
   optimize away 'noinline' after we are done running the simplifier.
   This is done in GHC.CoreToStg.Prep.cpeApp.

2. 'noinline' sometimes gets inserted automatically when we serialize an
   expression to the interface format, in GHC.CoreToIface.toIfaceVar.
   See Note [Inlining and hs-boot files] in GHC.CoreToIface

3. Given foo :: Eq a => [a] -> Bool, the expression
     noinline foo x xs
   where x::Int, will naturally desugar to
      noinline @Int (foo @Int dEqInt) x xs
   But now it's entirely possible that (foo @Int dEqInt) will inline foo,
   since 'foo' is no longer a lone variable -- see #18995

   Solution: in the desugarer, rewrite
      noinline (f x y)  ==>  noinline f x y
   This is done in GHC.HsToCore.Utils.mkCoreAppDs.
   This is only needed for noinlineId, not noInlineConstraintId (wrinkle
   (W1) below), because the latter never shows up in user code.

Wrinkles

(W1) Sometimes case (2) above needs to apply `noinline` to a type of kind
     Constraint; e.g.
                    noinline @(Eq Int) $dfEqInt
     We don't have type-or-kind polymorphism, so we simply have two `inline`
     Ids, namely `noinlineId` and `noinlineConstraintId`.

(W2) Note that noinline as currently implemented can hide some simplifications
     since it hides strictness from the demand analyser. Specifically, the
     demand analyser will treat 'noinline f x' as lazy in 'x', even if the
     demand signature of 'f' specifies that it is strict in its argument. We
     considered fixing this this by adding a special case to the demand
     analyser to address #16588. However, the special case seemed like a large
     and expensive hammer to address a rare case and consequently we rather
     opted to use a more minimal solution.

Note [nospecId magic]
~~~~~~~~~~~~~~~~~~~~~
The 'nospec' magic Id is used to ensure to make a value opaque to the typeclass
specialiser. In CorePrep, we inline 'nospec', turning (nospec e) into e.
Note that this happens *after* unfoldings are exposed in the interface file.
This is crucial: otherwise, we could import an unfolding in which
'nospec' has been inlined (= erased), and we would lose the benefit.

'nospec' is used:

* In the implementation of 'withDict': we insert 'nospec' so that the
  typeclass specialiser doesn't assume any two evidence terms of the
  same type are equal. See Note [withDict] in GHC.Tc.Instance.Class,
  and see test case T21575b for an example.

* To defeat the specialiser when we have incoherent instances.
  See Note [Coherence and specialisation: overview] in GHC.Core.InstEnv.

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 representation-polymorphic, i.e. the type variables can refer
to unlifted types as well (#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 GHC.Core.Tidy.

Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot.


-------------------------------------------------------------
@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
id_ty
                     (IdInfo
noCafIdInfo IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
evaldUnfolding    -- Note [evaldUnfoldings]
                                  IdInfo -> OneShotInfo -> IdInfo
`setOneShotInfo`   Type -> OneShotInfo
typeOneShot Type
id_ty)
   where
     id_ty :: Type
id_ty = Type
realWorldStatePrimTy

voidPrimId :: Id     -- Global constant :: Void#
                     -- The type Void# is now the same as (# #) (ticket #18441),
                     -- this identifier just signifies the (# #) datacon
                     -- and is kept for backwards compatibility.
                     -- We cannot define it in normal Haskell, since it's
                     -- a top-level unlifted value.
voidPrimId :: Id
voidPrimId  = Name -> Type -> IdInfo -> Id
pcMiscPrelId Name
voidPrimIdName Type
unboxedUnitTy
                (IdInfo
noCafIdInfo IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
unboxedUnitExpr)

unboxedUnitExpr :: CoreExpr
unboxedUnitExpr :: CoreExpr
unboxedUnitExpr = Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
unboxedUnitDataCon)

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

coercionTokenId :: Id         -- :: () ~# ()
coercionTokenId :: Id
coercionTokenId -- See Note [Coercion tokens] in "GHC.CoreToStg"
  = 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 Type
ty IdInfo
info
  = Name -> Type -> IdInfo -> Id
mkVanillaGlobalWithInfo Name
name Type
ty IdInfo
info