-----------------------------------------------------------------------------
--
-- Stg to C--: code generation for constructors
--
-- This module provides the support code for StgToCmm to deal with
-- constructors on the RHSs of let(rec)s.
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

module GHC.StgToCmm.DataCon (
        cgTopRhsCon, buildDynCon, bindConArgs
    ) where

import GHC.Prelude

import GHC.Platform

import GHC.Stg.Syntax
import GHC.Core  ( AltCon(..) )

import GHC.StgToCmm.Monad
import GHC.StgToCmm.Env
import GHC.StgToCmm.Heap
import GHC.StgToCmm.Layout
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure

import GHC.Cmm.Expr
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
import GHC.Cmm.Graph
import GHC.Runtime.Heap.Layout
import GHC.Types.CostCentre
import GHC.Unit
import GHC.Core.DataCon
import GHC.Data.FastString
import GHC.Types.Id
import GHC.Types.Id.Info( CafInfo( NoCafRefs ) )
import GHC.Types.Name (isInternalName)
import GHC.Types.RepType (countConRepArgs)
import GHC.Types.Literal
import GHC.Builtin.Utils
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Monad (mapMaybeM)

import Control.Monad
import Data.Char
import GHC.StgToCmm.Config (stgToCmmPlatform)
import GHC.StgToCmm.TagCheck (checkConArgsStatic, checkConArgsDyn)
import GHC.Utils.Outputable

---------------------------------------------------------------
--      Top-level constructors
---------------------------------------------------------------

cgTopRhsCon :: StgToCmmConfig
            -> Id               -- Name of thing bound to this RHS
            -> DataCon          -- Id
            -> ConstructorNumber
            -> [NonVoid StgArg] -- Args
            -> (CgIdInfo, FCode ())
cgTopRhsCon :: StgToCmmConfig
-> Id
-> DataCon
-> ConstructorNumber
-> [NonVoid StgArg]
-> (CgIdInfo, FCode ())
cgTopRhsCon StgToCmmConfig
cfg Id
id DataCon
con ConstructorNumber
mn [NonVoid StgArg]
args
  | Just CgIdInfo
static_info <- StgToCmmConfig
-> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
precomputedStaticConInfo_maybe StgToCmmConfig
cfg Id
id DataCon
con [NonVoid StgArg]
args
  , let static_code :: FCode ()
static_code | Name -> Bool
isInternalName Name
name = () -> FCode ()
forall a. a -> FCode a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    | Bool
otherwise           = FCode ()
gen_code
  = -- There is a pre-allocated static closure available; use it
    -- See Note [Precomputed static closures].
    -- For External bindings we must keep the binding,
    -- since importing modules will refer to it by name;
    -- but for Internal ones we can drop it altogether
    -- See Note [About the NameSorts] in "GHC.Types.Name" for Internal/External
    (CgIdInfo
static_info, FCode ()
static_code)

  -- Otherwise generate a closure for the constructor.
  | Bool
otherwise
  = (CgIdInfo
id_Info, FCode ()
gen_code)

  where
   platform :: Platform
platform      = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
   id_Info :: CgIdInfo
id_Info       = Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo Platform
platform Id
id (DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con) (CLabel -> CmmLit
CmmLabel CLabel
closure_label)
   name :: Name
name          = Id -> Name
idName Id
id
   caffy :: CafInfo
caffy         = Id -> CafInfo
idCafInfo Id
id -- any stgArgHasCafRefs args
   closure_label :: CLabel
closure_label = Name -> CafInfo -> CLabel
mkClosureLabel Name
name CafInfo
caffy

   gen_code :: FCode ()
gen_code =
     do { Profile
profile <- FCode Profile
getProfile
        ; Module
this_mod <- FCode Module
getModuleName
        ; Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32) (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
              -- Windows DLLs have a problem with static cross-DLL refs.
              Bool -> FCode ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (Bool -> Bool
not (Platform -> Bool -> Module -> DataCon -> [StgArg] -> Bool
isDllConApp Platform
platform (StgToCmmConfig -> Bool
stgToCmmExtDynRefs StgToCmmConfig
cfg) Module
this_mod DataCon
con ((NonVoid StgArg -> StgArg) -> [NonVoid StgArg] -> [StgArg]
forall a b. (a -> b) -> [a] -> [b]
map NonVoid StgArg -> StgArg
forall a. NonVoid a -> a
fromNonVoid [NonVoid StgArg]
args)))
        ; Bool -> (() -> FCode ()) -> () -> FCode ()
forall a. HasCallStack => Bool -> a -> a
assert ([NonVoid StgArg]
args [NonVoid StgArg] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` DataCon -> Int
countConRepArgs DataCon
con ) () -> FCode ()
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ; SDoc -> DataCon -> [StgArg] -> FCode ()
checkConArgsStatic (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TagCheck failed - Top level con") DataCon
con ((NonVoid StgArg -> StgArg) -> [NonVoid StgArg] -> [StgArg]
forall a b. (a -> b) -> [a] -> [b]
map NonVoid StgArg -> StgArg
forall a. NonVoid a -> a
fromNonVoid [NonVoid StgArg]
args)
        -- LAY IT OUT
        ; let
            (Int
tot_wds, --  #ptr_wds + #nonptr_wds
             Int
ptr_wds, --  #ptr_wds
             [FieldOffOrPadding StgArg]
nv_args_w_offsets) =
                 Profile
-> ClosureHeader
-> [NonVoid (PrimRep, StgArg)]
-> (Int, Int, [FieldOffOrPadding StgArg])
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [FieldOffOrPadding a])
mkVirtHeapOffsetsWithPadding Profile
profile ClosureHeader
StdHeader ([NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
addArgReps [NonVoid StgArg]
args)

        ; let
            -- Decompose padding into units of length 8, 4, 2, or 1 bytes to
            -- allow the implementation of mk_payload to use widthFromBytes,
            -- which only handles these cases.
            fix_padding :: [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding (x :: FieldOffOrPadding a
x@(Padding Int
n Int
off) : [FieldOffOrPadding a]
rest)
              | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0                 = [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding [FieldOffOrPadding a]
rest
              | Int
n Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
1,Int
2,Int
4,Int
8]     = FieldOffOrPadding a
x FieldOffOrPadding a
-> [FieldOffOrPadding a] -> [FieldOffOrPadding a]
forall a. a -> [a] -> [a]
: [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding [FieldOffOrPadding a]
rest
              | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
8                  = Int -> [FieldOffOrPadding a]
add_pad Int
8
              | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4                  = Int -> [FieldOffOrPadding a]
add_pad Int
4
              | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2                  = Int -> [FieldOffOrPadding a]
add_pad Int
2
              | Bool
otherwise              = Int -> [FieldOffOrPadding a]
add_pad Int
1
              where add_pad :: Int -> [FieldOffOrPadding a]
add_pad Int
m = Int -> Int -> FieldOffOrPadding a
forall a. Int -> Int -> FieldOffOrPadding a
Padding Int
m Int
off FieldOffOrPadding a
-> [FieldOffOrPadding a] -> [FieldOffOrPadding a]
forall a. a -> [a] -> [a]
: [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding (Int -> Int -> FieldOffOrPadding a
forall a. Int -> Int -> FieldOffOrPadding a
Padding (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
m) FieldOffOrPadding a
-> [FieldOffOrPadding a] -> [FieldOffOrPadding a]
forall a. a -> [a] -> [a]
: [FieldOffOrPadding a]
rest)
            fix_padding (FieldOffOrPadding a
x : [FieldOffOrPadding a]
rest)     = FieldOffOrPadding a
x FieldOffOrPadding a
-> [FieldOffOrPadding a] -> [FieldOffOrPadding a]
forall a. a -> [a] -> [a]
: [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding [FieldOffOrPadding a]
rest
            fix_padding []             = []

            mk_payload :: FieldOffOrPadding StgArg -> FCode CmmLit
mk_payload (Padding Int
len Int
_) = CmmLit -> FCode CmmLit
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Width -> CmmLit
CmmInt Integer
0 (Int -> Width
widthFromBytes Int
len))
            mk_payload (FieldOff NonVoid StgArg
arg Int
_) = do
                CmmExpr
amode <- NonVoid StgArg -> FCode CmmExpr
getArgAmode NonVoid StgArg
arg
                case CmmExpr
amode of
                  CmmLit CmmLit
lit -> CmmLit -> FCode CmmLit
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return CmmLit
lit
                  CmmExpr
_          -> String -> FCode CmmLit
forall a. HasCallStack => String -> a
panic String
"GHC.StgToCmm.DataCon.cgTopRhsCon"

            nonptr_wds :: Int
nonptr_wds = Int
tot_wds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ptr_wds

             -- we're not really going to emit an info table, so having
             -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields
             -- needs to poke around inside it.
            info_tbl :: CmmInfoTable
info_tbl = Profile
-> DataCon
-> ConInfoTableLocation
-> Bool
-> Int
-> Int
-> CmmInfoTable
mkDataConInfoTable Profile
profile DataCon
con (Module -> ConstructorNumber -> ConInfoTableLocation
addModuleLoc Module
this_mod ConstructorNumber
mn) Bool
True Int
ptr_wds Int
nonptr_wds


        ; [CmmLit]
payload <- (FieldOffOrPadding StgArg -> FCode CmmLit)
-> [FieldOffOrPadding StgArg] -> FCode [CmmLit]
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 FieldOffOrPadding StgArg -> FCode CmmLit
mk_payload ([FieldOffOrPadding StgArg] -> [FieldOffOrPadding StgArg]
forall {a}. [FieldOffOrPadding a] -> [FieldOffOrPadding a]
fix_padding [FieldOffOrPadding StgArg]
nv_args_w_offsets)
                -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
                -- NB2: all the amodes should be Lits!
                --      TODO (osa): Why?

                -- BUILD THE OBJECT
                --
            -- We're generating info tables, so we don't know and care about
            -- what the actual arguments are. Using () here as the place holder.

        ; CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()
emitDataCon CLabel
closure_label CmmInfoTable
info_tbl CostCentreStack
dontCareCCS [CmmLit]
payload }

addModuleLoc :: Module -> ConstructorNumber -> ConInfoTableLocation
addModuleLoc :: Module -> ConstructorNumber -> ConInfoTableLocation
addModuleLoc Module
this_mod ConstructorNumber
mn = do
  case ConstructorNumber
mn of
    ConstructorNumber
NoNumber -> ConInfoTableLocation
DefinitionSite
    Numbered Int
n -> Module -> Int -> ConInfoTableLocation
UsageSite Module
this_mod Int
n

---------------------------------------------------------------
--      Lay out and allocate non-top-level constructors
---------------------------------------------------------------

buildDynCon :: Id                 -- Name of the thing to which this constr will
                                  -- be bound
            -> ConstructorNumber
            -> Bool               -- is it genuinely bound to that name, or just
                                  -- for profiling?
            -> CostCentreStack    -- Where to grab cost centre from;
                                  -- current CCS if currentOrSubsumedCCS
            -> DataCon            -- The data constructor
            -> [NonVoid StgArg]   -- Its args
            -> FCode (CgIdInfo, FCode CmmAGraph)
               -- Return details about how to find it and initialization code
buildDynCon :: Id
-> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon Id
binder ConstructorNumber
mn Bool
actually_bound CostCentreStack
cc DataCon
con [NonVoid StgArg]
args
    = do StgToCmmConfig
cfg <- FCode StgToCmmConfig
getStgToCmmConfig
         --   pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True
         case StgToCmmConfig
-> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
precomputedStaticConInfo_maybe StgToCmmConfig
cfg Id
binder DataCon
con [NonVoid StgArg]
args of
           Just CgIdInfo
cgInfo -> (CgIdInfo, FCode CmmAGraph) -> FCode (CgIdInfo, FCode CmmAGraph)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CgIdInfo
cgInfo, CmmAGraph -> FCode CmmAGraph
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return CmmAGraph
mkNop)
           Maybe CgIdInfo
Nothing     -> Id
-> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' Id
binder ConstructorNumber
mn Bool
actually_bound CostCentreStack
cc DataCon
con [NonVoid StgArg]
args


buildDynCon' :: Id
             -> ConstructorNumber
             -> Bool
             -> CostCentreStack
             -> DataCon
             -> [NonVoid StgArg]
             -> FCode (CgIdInfo, FCode CmmAGraph)
{- We used to pass a boolean indicating whether all the
args were of size zero, so we could use a static
constructor; but I concluded that it just isn't worth it.
Now I/O uses unboxed tuples there just aren't any constructors
with all size-zero args.

The reason for having a separate argument, rather than looking at
the addr modes of the args is that we may be in a "knot", and
premature looking at the args will cause the compiler to black-hole!
-}
-------- buildDynCon': the general case -----------
buildDynCon' :: Id
-> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' Id
binder ConstructorNumber
mn Bool
actually_bound CostCentreStack
ccs DataCon
con [NonVoid StgArg]
args
  = do  { (CgIdInfo
id_info, LocalReg
reg) <- Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
rhsIdInfo Id
binder LambdaFormInfo
lf_info
        ; (CgIdInfo, FCode CmmAGraph) -> FCode (CgIdInfo, FCode CmmAGraph)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CgIdInfo
id_info, LocalReg -> FCode CmmAGraph
gen_code LocalReg
reg)
        }
 where
  lf_info :: LambdaFormInfo
lf_info = DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con

  gen_code :: LocalReg -> FCode CmmAGraph
gen_code LocalReg
reg
    = do  { Module
modu <- FCode Module
getModuleName
          ; StgToCmmConfig
cfg  <- FCode StgToCmmConfig
getStgToCmmConfig
          ; let platform :: Platform
platform = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
                profile :: Profile
profile  = StgToCmmConfig -> Profile
stgToCmmProfile  StgToCmmConfig
cfg
                (Int
tot_wds, Int
ptr_wds, [(NonVoid StgArg, Int)]
args_w_offsets)
                   = Profile
-> [NonVoid (PrimRep, StgArg)]
-> (Int, Int, [(NonVoid StgArg, Int)])
forall a.
Profile -> [NonVoid (PrimRep, a)] -> (Int, Int, [(NonVoid a, Int)])
mkVirtConstrOffsets Profile
profile ([NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
addArgReps [NonVoid StgArg]
args)
                nonptr_wds :: Int
nonptr_wds = Int
tot_wds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ptr_wds
                info_tbl :: CmmInfoTable
info_tbl = Profile
-> DataCon
-> ConInfoTableLocation
-> Bool
-> Int
-> Int
-> CmmInfoTable
mkDataConInfoTable Profile
profile DataCon
con (Module -> ConstructorNumber -> ConInfoTableLocation
addModuleLoc Module
modu ConstructorNumber
mn) Bool
False
                                Int
ptr_wds Int
nonptr_wds
          ; let ticky_name :: Maybe Id
ticky_name | Bool
actually_bound = Id -> Maybe Id
forall a. a -> Maybe a
Just Id
binder
                           | Bool
otherwise = Maybe Id
forall a. Maybe a
Nothing

          ; SDoc -> DataCon -> [StgArg] -> FCode ()
checkConArgsDyn (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TagCheck failed on constructor application.") Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                                   String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"On binder:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
binder SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Constructor:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con) DataCon
con ((NonVoid StgArg -> StgArg) -> [NonVoid StgArg] -> [StgArg]
forall a b. (a -> b) -> [a] -> [b]
map NonVoid StgArg -> StgArg
forall a. NonVoid a -> a
fromNonVoid [NonVoid StgArg]
args)
          ; CmmExpr
hp_plus_n <- Maybe Id
-> CmmInfoTable
-> LambdaFormInfo
-> CmmExpr
-> CmmExpr
-> [(NonVoid StgArg, Int)]
-> FCode CmmExpr
allocDynClosure Maybe Id
ticky_name CmmInfoTable
info_tbl LambdaFormInfo
lf_info
                                          CmmExpr
use_cc CmmExpr
blame_cc [(NonVoid StgArg, Int)]
args_w_offsets
          ; CmmAGraph -> FCode CmmAGraph
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (Platform -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
mkRhsInit Platform
platform LocalReg
reg LambdaFormInfo
lf_info CmmExpr
hp_plus_n) }
    where
      use_cc :: CmmExpr
use_cc      -- cost-centre to stick in the object
        | CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs = CmmExpr
cccsExpr
        | Bool
otherwise        = String -> CmmExpr
forall a. HasCallStack => String -> a
panic String
"buildDynCon: non-current CCS not implemented"

      blame_cc :: CmmExpr
blame_cc = CmmExpr
use_cc -- cost-centre on which to blame the alloc (same)


{- Note [Precomputed static closures]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

For Char/Int closures there are some value closures
built into the RTS. This is the case for all values in
the range mINT_INTLIKE .. mAX_INTLIKE (or CHARLIKE).
See Note [CHARLIKE and INTLIKE closures] in the RTS code.

Similarly zero-arity constructors have a closure
in their defining Module we can use.

If possible we prefer to refer to those existing
closure instead of building new ones.

This is true at compile time where we do this replacement
in this module.
But also at runtime where the GC does the same (but only for
INT/CHAR closures).

`precomputedStaticConInfo_maybe` checks if a given constructor application
can be replaced with a reference to a existing static closure.

If so the code will reference the existing closure when accessing
the binding.
Unless the binding is visible to other modules we also generate
no code for the binding itself. We can do this since then we can
always reference the existing closure.

See Note [About the NameSorts] for the definition of external names.
For external bindings we must still generate a closure,
but won't use it inside this module.
This can sometimes reduce cache pressure. Since:
* If somebody uses the exported binding:
  + This module will reference the existing closure.
  + GC will reference the existing closure.
  + The importing module will reference the built closure.
* If nobody uses the exported binding:
  + This module will reference the RTS closures.
  + GC references the RTS closures

In the later case we avoided loading the built closure into the cache which
is what we optimize for here.

Consider this example using Ints.

    module M(externalInt, foo, bar) where

    externalInt = 1 :: Int
    internalInt = 1 :: Int
    { -# NOINLINE foo #- }
    foo = Just internalInt :: Maybe Int
    bar = Just externalInt

    ==================== STG: ====================
    externalInt = I#! [1#];

    bar = Just! [externalInt];

    internalInt_rc = I#! [2#];

    foo = Just! [internalInt_rc];

For externally visible bindings we must generate closures
since those may be referenced by their symbol `<name>_closure`
when imported.

`externalInt` is visible to other modules so we generate a closure:

    [section ""data" . M.externalInt_closure" {
        M.externalInt_closure:
            const GHC.Types.I#_con_info;
            const 1;
    }]

It will be referenced inside this module via `M.externalInt_closure+1`

`internalInt` is however a internal name. As such we generate no code for
it. References to it are replaced with references to the static closure as
we can see in the closure built for `foo`:

    [section ""data" . M.foo_closure" {
        M.foo_closure:
            const GHC.Maybe.Just_con_info;
            const stg_INTLIKE_closure+289; // == I# 2
            const 3;
    }]

This holds for both local and top level bindings.

We don't support this optimization when compiling into Windows DLLs yet
because they don't support cross package data references well.
-}

-- (precomputedStaticConInfo_maybe cfg id con args)
--     returns (Just cg_id_info)
-- if there is a precomputed static closure for (con args).
-- In that case, cg_id_info addresses it.
-- See Note [Precomputed static closures]
precomputedStaticConInfo_maybe :: StgToCmmConfig -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
precomputedStaticConInfo_maybe :: StgToCmmConfig
-> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
precomputedStaticConInfo_maybe StgToCmmConfig
cfg Id
binder DataCon
con []
-- Nullary constructors
  | DataCon -> Bool
isNullaryRepDataCon DataCon
con
  = CgIdInfo -> Maybe CgIdInfo
forall a. a -> Maybe a
Just (CgIdInfo -> Maybe CgIdInfo) -> CgIdInfo -> Maybe CgIdInfo
forall a b. (a -> b) -> a -> b
$ Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo (StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg) Id
binder (DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con)
                (CLabel -> CmmLit
CmmLabel (Name -> CafInfo -> CLabel
mkClosureLabel (DataCon -> Name
dataConName DataCon
con) CafInfo
NoCafRefs))
precomputedStaticConInfo_maybe StgToCmmConfig
cfg Id
binder DataCon
con [NonVoid StgArg
arg]
  -- Int/Char values with existing closures in the RTS
  | Bool
intClosure Bool -> Bool -> Bool
|| Bool
charClosure
  , Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
/= OS
OSMinGW32 Bool -> Bool -> Bool
|| Bool -> Bool
not (StgToCmmConfig -> Bool
stgToCmmPIE StgToCmmConfig
cfg Bool -> Bool -> Bool
|| StgToCmmConfig -> Bool
stgToCmmPIC StgToCmmConfig
cfg)
  , Just Integer
val <- NonVoid StgArg -> Maybe Integer
getClosurePayload NonVoid StgArg
arg
  , Integer -> Bool
inRange Integer
val
  = let intlike_lbl :: CLabel
intlike_lbl   = UnitId -> FastString -> CLabel
mkCmmClosureLabel UnitId
rtsUnitId (String -> FastString
fsLit String
label)
        val_int :: Int
val_int = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
val :: Int
        offsetW :: Int
offsetW = (Int
val_int Int -> Int -> Int
forall a. Num a => a -> a -> a
- Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
min_static_range) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Profile -> Int
fixedHdrSizeW Profile
profile Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                -- INTLIKE/CHARLIKE closures consist of a header and one word payload
        static_amode :: CmmLit
static_amode = Platform -> CLabel -> Int -> CmmLit
cmmLabelOffW Platform
platform CLabel
intlike_lbl Int
offsetW
    in CgIdInfo -> Maybe CgIdInfo
forall a. a -> Maybe a
Just (CgIdInfo -> Maybe CgIdInfo) -> CgIdInfo -> Maybe CgIdInfo
forall a b. (a -> b) -> a -> b
$ Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo Platform
platform Id
binder (DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con) CmmLit
static_amode
  where
    profile :: Profile
profile     = StgToCmmConfig -> Profile
stgToCmmProfile  StgToCmmConfig
cfg
    platform :: Platform
platform    = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
    intClosure :: Bool
intClosure  = DataCon -> Bool
maybeIntLikeCon  DataCon
con
    charClosure :: Bool
charClosure = DataCon -> Bool
maybeCharLikeCon DataCon
con
    getClosurePayload :: NonVoid StgArg -> Maybe Integer
getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumType
LitNumInt Integer
val))) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
val
    getClosurePayload (NonVoid (StgLitArg (LitChar Char
val))) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> (Char -> Int) -> Char -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord (Char -> Integer) -> Char -> Integer
forall a b. (a -> b) -> a -> b
$ Char
val)
    getClosurePayload NonVoid StgArg
_ = Maybe Integer
forall a. Maybe a
Nothing
    -- Avoid over/underflow by comparisons at type Integer!
    inRange :: Integer -> Bool
    inRange :: Integer -> Bool
inRange Integer
val
      = Integer
val Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
min_static_range Bool -> Bool -> Bool
&& Integer
val Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
max_static_range

    constants :: PlatformConstants
constants = Platform -> PlatformConstants
platformConstants Platform
platform

    min_static_range :: Integer
    min_static_range :: Integer
min_static_range
      | Bool
intClosure = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PlatformConstants -> Int
pc_MIN_INTLIKE PlatformConstants
constants)
      | Bool
charClosure = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PlatformConstants -> Int
pc_MIN_CHARLIKE PlatformConstants
constants)
      | Bool
otherwise = String -> Integer
forall a. HasCallStack => String -> a
panic String
"precomputedStaticConInfo_maybe: Unknown closure type"
    max_static_range :: Integer
max_static_range
      | Bool
intClosure = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PlatformConstants -> Int
pc_MAX_INTLIKE PlatformConstants
constants)
      | Bool
charClosure = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PlatformConstants -> Int
pc_MAX_CHARLIKE PlatformConstants
constants)
      | Bool
otherwise = String -> Integer
forall a. HasCallStack => String -> a
panic String
"precomputedStaticConInfo_maybe: Unknown closure type"
    label :: String
label
      | Bool
intClosure = String
"stg_INTLIKE"
      | Bool
charClosure =  String
"stg_CHARLIKE"
      | Bool
otherwise = String -> String
forall a. HasCallStack => String -> a
panic String
"precomputedStaticConInfo_maybe: Unknown closure type"

precomputedStaticConInfo_maybe StgToCmmConfig
_ Id
_ DataCon
_ [NonVoid StgArg]
_ = Maybe CgIdInfo
forall a. Maybe a
Nothing

---------------------------------------------------------------
--      Binding constructor arguments
---------------------------------------------------------------

bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
-- bindConArgs is called from cgAlt of a case
-- (bindConArgs con args) augments the environment with bindings for the
-- binders args, assuming that we have just returned from a 'case' which
-- found a con
bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
bindConArgs (DataAlt DataCon
con) LocalReg
base [NonVoid Id]
args
  = Bool -> FCode [LocalReg] -> FCode [LocalReg]
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (DataCon -> Bool
isUnboxedTupleDataCon DataCon
con)) (FCode [LocalReg] -> FCode [LocalReg])
-> FCode [LocalReg] -> FCode [LocalReg]
forall a b. (a -> b) -> a -> b
$
    do Profile
profile <- FCode Profile
getProfile
       Platform
platform <- FCode Platform
getPlatform
       let (Int
_, Int
_, [(NonVoid Id, Int)]
args_w_offsets) = Profile
-> [NonVoid (PrimRep, Id)] -> (Int, Int, [(NonVoid Id, Int)])
forall a.
Profile -> [NonVoid (PrimRep, a)] -> (Int, Int, [(NonVoid a, Int)])
mkVirtConstrOffsets Profile
profile ([NonVoid Id] -> [NonVoid (PrimRep, Id)]
addIdReps [NonVoid Id]
args)
           tag :: Int
tag = Platform -> DataCon -> Int
tagForCon Platform
platform DataCon
con

           -- The binding below forces the masking out of the tag bits
           -- when accessing the constructor field.
           bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)
           bind_arg :: (NonVoid Id, Int) -> FCode (Maybe LocalReg)
bind_arg (arg :: NonVoid Id
arg@(NonVoid Id
b), Int
offset)
             | Id -> Bool
isDeadBinder Id
b  -- See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr
             = Maybe LocalReg -> FCode (Maybe LocalReg)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LocalReg
forall a. Maybe a
Nothing
             | Bool
otherwise
             = do { CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ Platform -> LocalReg -> LocalReg -> Int -> Int -> CmmAGraph
mkTaggedObjectLoad Platform
platform (Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform NonVoid Id
arg)
                                              LocalReg
base Int
offset Int
tag
                  ; LocalReg -> Maybe LocalReg
forall a. a -> Maybe a
Just (LocalReg -> Maybe LocalReg)
-> FCode LocalReg -> FCode (Maybe LocalReg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonVoid Id -> FCode LocalReg
bindArgToReg NonVoid Id
arg }

       ((NonVoid Id, Int) -> FCode (Maybe LocalReg))
-> [(NonVoid Id, Int)] -> FCode [LocalReg]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (NonVoid Id, Int) -> FCode (Maybe LocalReg)
bind_arg [(NonVoid Id, Int)]
args_w_offsets

bindConArgs AltCon
_other_con LocalReg
_base [NonVoid Id]
args
  = Bool
-> ([LocalReg] -> FCode [LocalReg])
-> [LocalReg]
-> FCode [LocalReg]
forall a. HasCallStack => Bool -> a -> a
assert ([NonVoid Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NonVoid Id]
args ) [LocalReg] -> FCode [LocalReg]
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return []