{-# LANGUAGE CPP #-}

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

module StgCmmCon (
        cgTopRhsCon, buildDynCon, bindConArgs
    ) where

#include "HsVersions.h"

import GhcPrelude

import StgSyn
import CoreSyn  ( AltCon(..) )

import StgCmmMonad
import StgCmmEnv
import StgCmmHeap
import StgCmmLayout
import StgCmmUtils
import StgCmmClosure

import CmmExpr
import CmmUtils
import CLabel
import MkGraph
import SMRep
import CostCentre
import Module
import DataCon
import DynFlags
import FastString
import Id
import RepType (countConRepArgs)
import Literal
import PrelInfo
import Outputable
import Platform
import Util
import MonadUtils (mapMaybeM)

import Control.Monad
import Data.Char



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

cgTopRhsCon :: DynFlags
            -> Id               -- Name of thing bound to this RHS
            -> DataCon          -- Id
            -> [NonVoid StgArg] -- Args
            -> (CgIdInfo, FCode ())
cgTopRhsCon :: DynFlags
-> Id -> DataCon -> [NonVoid StgArg] -> (CgIdInfo, FCode ())
cgTopRhsCon dflags :: DynFlags
dflags id :: Id
id con :: DataCon
con args :: [NonVoid StgArg]
args =
    let id_info :: CgIdInfo
id_info = DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo DynFlags
dflags Id
id (DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con) (CLabel -> CmmLit
CmmLabel CLabel
closure_label)
    in (CgIdInfo
id_info, FCode ()
gen_code)
  where
   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 { Module
this_mod <- FCode Module
getModuleName
        ; Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) 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.
              MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )
        ; ASSERT( args `lengthIs` countConRepArgs con ) return ()

        -- LAY IT OUT
        ; let
            (tot_wds :: Int
tot_wds, --  #ptr_wds + #nonptr_wds
             ptr_wds :: Int
ptr_wds, --  #ptr_wds
             nv_args_w_offsets :: [FieldOffOrPadding StgArg]
nv_args_w_offsets) =
                 DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, StgArg)]
-> (Int, Int, [FieldOffOrPadding StgArg])
forall a.
DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [FieldOffOrPadding a])
mkVirtHeapOffsetsWithPadding DynFlags
dflags ClosureHeader
StdHeader ([NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
addArgReps [NonVoid StgArg]
args)

            mk_payload :: FieldOffOrPadding StgArg -> FCode CmmLit
mk_payload (Padding len :: Int
len _) = CmmLit -> FCode CmmLit
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Width -> CmmLit
CmmInt 0 (Int -> Width
widthFromBytes Int
len))
            mk_payload (FieldOff arg :: NonVoid StgArg
arg _) = do
                CmmExpr
amode <- NonVoid StgArg -> FCode CmmExpr
getArgAmode NonVoid StgArg
arg
                case CmmExpr
amode of
                  CmmLit lit :: CmmLit
lit -> CmmLit -> FCode CmmLit
forall (m :: * -> *) a. Monad m => a -> m a
return CmmLit
lit
                  _          -> String -> FCode CmmLit
forall a. String -> a
panic "StgCmmCon.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 = DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable
mkDataConInfoTable DynFlags
dflags DataCon
con 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)
mapM FieldOffOrPadding StgArg -> FCode CmmLit
mk_payload [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?

        ; let closure_rep :: [CmmLit]
closure_rep = DynFlags
-> CmmInfoTable
-> CostCentreStack
-> CafInfo
-> [CmmLit]
-> [CmmLit]
mkStaticClosureFields
                             DynFlags
dflags
                             CmmInfoTable
info_tbl
                             CostCentreStack
dontCareCCS                -- Because it's static data
                             CafInfo
caffy                      -- Has CAF refs
                             [CmmLit]
payload

                -- BUILD THE OBJECT
        ; CLabel -> [CmmLit] -> FCode ()
emitDataLits CLabel
closure_label [CmmLit]
closure_rep

        ; () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }


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

buildDynCon :: Id                 -- Name of the thing to which this constr will
                                  -- be bound
            -> 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
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon binder :: Id
binder actually_bound :: Bool
actually_bound cc :: CostCentreStack
cc con :: DataCon
con args :: [NonVoid StgArg]
args
    = do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
         DynFlags
-> Platform
-> Id
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' DynFlags
dflags (DynFlags -> Platform
targetPlatform DynFlags
dflags) Id
binder Bool
actually_bound CostCentreStack
cc DataCon
con [NonVoid StgArg]
args


buildDynCon' :: DynFlags
             -> Platform
             -> Id -> 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': Nullary constructors --------------
-- First we deal with the case of zero-arity constructors.  They
-- will probably be unfolded, so we don't expect to see this case much,
-- if at all, but it does no harm, and sets the scene for characters.
--
-- In the case of zero-arity constructors, or, more accurately, those
-- which have exclusively size-zero (VoidRep) args, we generate no code
-- at all.

buildDynCon' :: DynFlags
-> Platform
-> Id
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' dflags :: DynFlags
dflags _ binder :: Id
binder _ _cc :: CostCentreStack
_cc con :: DataCon
con []
  | DataCon -> Bool
isNullaryRepDataCon DataCon
con
  = (CgIdInfo, FCode CmmAGraph) -> FCode (CgIdInfo, FCode CmmAGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo DynFlags
dflags Id
binder (DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con)
                (CLabel -> CmmLit
CmmLabel (Name -> CafInfo -> CLabel
mkClosureLabel (DataCon -> Name
dataConName DataCon
con) (Id -> CafInfo
idCafInfo Id
binder))),
            CmmAGraph -> FCode CmmAGraph
forall (m :: * -> *) a. Monad m => a -> m a
return CmmAGraph
mkNop)

-------- buildDynCon': Charlike and Intlike constructors -----------
{- The following three paragraphs about @Char@-like and @Int@-like
closures are obsolete, but I don't understand the details well enough
to properly word them, sorry. I've changed the treatment of @Char@s to
be analogous to @Int@s: only a subset is preallocated, because @Char@
has now 31 bits. Only literals are handled here. -- Qrczak

Now for @Char@-like closures.  We generate an assignment of the
address of the closure to a temporary.  It would be possible simply to
generate no code, and record the addressing mode in the environment,
but we'd have to be careful if the argument wasn't a constant --- so
for simplicity we just always assign to a temporary.

Last special case: @Int@-like closures.  We only special-case the
situation in which the argument is a literal in the range
@mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can
work with any old argument, but for @Int@-like ones the argument has
to be a literal.  Reason: @Char@ like closures have an argument type
which is guaranteed in range.

Because of this, we use can safely return an addressing mode.

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

buildDynCon' dflags :: DynFlags
dflags platform :: Platform
platform binder :: Id
binder _ _cc :: CostCentreStack
_cc con :: DataCon
con [arg :: NonVoid StgArg
arg]
  | DataCon -> Bool
maybeIntLikeCon DataCon
con
  , Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
/= OS
OSMinGW32 Bool -> Bool -> Bool
|| Bool -> Bool
not (DynFlags -> Bool
positionIndependent DynFlags
dflags)
  , NonVoid (StgLitArg (LitNumber LitNumInt val :: Integer
val _)) <- NonVoid StgArg
arg
  , Integer
val Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DynFlags -> Int
mAX_INTLIKE DynFlags
dflags) -- Comparisons at type Integer!
  , Integer
val Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DynFlags -> Int
mIN_INTLIKE DynFlags
dflags) -- ...ditto...
  = do  { let intlike_lbl :: CLabel
intlike_lbl   = UnitId -> FastString -> CLabel
mkCmmClosureLabel UnitId
rtsUnitId (String -> FastString
fsLit "stg_INTLIKE")
              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
- DynFlags -> Int
mIN_INTLIKE DynFlags
dflags) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (DynFlags -> Int
fixedHdrSizeW DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
                -- INTLIKE closures consist of a header and one word payload
              intlike_amode :: CmmLit
intlike_amode = DynFlags -> CLabel -> Int -> CmmLit
cmmLabelOffW DynFlags
dflags CLabel
intlike_lbl Int
offsetW
        ; (CgIdInfo, FCode CmmAGraph) -> FCode (CgIdInfo, FCode CmmAGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return ( DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo DynFlags
dflags Id
binder (DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con) CmmLit
intlike_amode
                 , CmmAGraph -> FCode CmmAGraph
forall (m :: * -> *) a. Monad m => a -> m a
return CmmAGraph
mkNop) }

buildDynCon' dflags :: DynFlags
dflags platform :: Platform
platform binder :: Id
binder _ _cc :: CostCentreStack
_cc con :: DataCon
con [arg :: NonVoid StgArg
arg]
  | DataCon -> Bool
maybeCharLikeCon DataCon
con
  , Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
/= OS
OSMinGW32 Bool -> Bool -> Bool
|| Bool -> Bool
not (DynFlags -> Bool
positionIndependent DynFlags
dflags)
  , NonVoid (StgLitArg (LitChar val :: Char
val)) <- NonVoid StgArg
arg
  , let val_int :: Int
val_int = Char -> Int
ord Char
val :: Int
  , Int
val_int Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= DynFlags -> Int
mAX_CHARLIKE DynFlags
dflags
  , Int
val_int Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= DynFlags -> Int
mIN_CHARLIKE DynFlags
dflags
  = do  { let charlike_lbl :: CLabel
charlike_lbl   = UnitId -> FastString -> CLabel
mkCmmClosureLabel UnitId
rtsUnitId (String -> FastString
fsLit "stg_CHARLIKE")
              offsetW :: Int
offsetW = (Int
val_int Int -> Int -> Int
forall a. Num a => a -> a -> a
- DynFlags -> Int
mIN_CHARLIKE DynFlags
dflags) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (DynFlags -> Int
fixedHdrSizeW DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
                -- CHARLIKE closures consist of a header and one word payload
              charlike_amode :: CmmLit
charlike_amode = DynFlags -> CLabel -> Int -> CmmLit
cmmLabelOffW DynFlags
dflags CLabel
charlike_lbl Int
offsetW
        ; (CgIdInfo, FCode CmmAGraph) -> FCode (CgIdInfo, FCode CmmAGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return ( DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo DynFlags
dflags Id
binder (DataCon -> LambdaFormInfo
mkConLFInfo DataCon
con) CmmLit
charlike_amode
                 , CmmAGraph -> FCode CmmAGraph
forall (m :: * -> *) a. Monad m => a -> m a
return CmmAGraph
mkNop) }

-------- buildDynCon': the general case -----------
buildDynCon' dflags :: DynFlags
dflags _ binder :: Id
binder actually_bound :: Bool
actually_bound ccs :: CostCentreStack
ccs con :: DataCon
con args :: [NonVoid StgArg]
args
  = do  { (id_info :: CgIdInfo
id_info, reg :: LocalReg
reg) <- Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
rhsIdInfo Id
binder LambdaFormInfo
lf_info
        ; (CgIdInfo, FCode CmmAGraph) -> FCode (CgIdInfo, FCode CmmAGraph)
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 reg :: LocalReg
reg
    = do  { let (tot_wds :: Int
tot_wds, ptr_wds :: Int
ptr_wds, args_w_offsets :: [(NonVoid StgArg, Int)]
args_w_offsets)
                  = DynFlags
-> [NonVoid (PrimRep, StgArg)]
-> (Int, Int, [(NonVoid StgArg, Int)])
forall a.
DynFlags
-> [NonVoid (PrimRep, a)] -> (Int, Int, [(NonVoid a, Int)])
mkVirtConstrOffsets DynFlags
dflags ([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 = DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable
mkDataConInfoTable DynFlags
dflags DataCon
con 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

          ; 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 (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
mkRhsInit DynFlags
dflags 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. String -> a
panic "buildDynCon: non-current CCS not implemented"

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


---------------------------------------------------------------
--      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 con :: DataCon
con) base :: LocalReg
base args :: [NonVoid Id]
args
  = ASSERT(not (isUnboxedTupleCon con))
    do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       let (_, _, args_w_offsets :: [(NonVoid Id, Int)]
args_w_offsets) = DynFlags
-> [NonVoid (PrimRep, Id)] -> (Int, Int, [(NonVoid Id, Int)])
forall a.
DynFlags
-> [NonVoid (PrimRep, a)] -> (Int, Int, [(NonVoid a, Int)])
mkVirtConstrOffsets DynFlags
dflags ([NonVoid Id] -> [NonVoid (PrimRep, Id)]
addIdReps [NonVoid Id]
args)
           tag :: Int
tag = DynFlags -> DataCon -> Int
tagForCon DynFlags
dflags 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 b :: Id
b), offset :: Int
offset)
             | Id -> Bool
isDeadBinder Id
b  -- See Note [Dead-binder optimisation] in StgCmmExpr
             = Maybe LocalReg -> FCode (Maybe LocalReg)
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
$ DynFlags -> LocalReg -> LocalReg -> Int -> Int -> CmmAGraph
mkTaggedObjectLoad DynFlags
dflags (DynFlags -> NonVoid Id -> LocalReg
idToReg DynFlags
dflags 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 _other_con :: AltCon
_other_con _base :: LocalReg
_base args :: [NonVoid Id]
args
  = ASSERT( null args ) return []