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 StgCmmProf ( curCCS )
import CmmExpr
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
cgTopRhsCon :: DynFlags
-> Id
-> DataCon
-> [NonVoid StgArg]
-> (CgIdInfo, FCode ())
cgTopRhsCon dflags id con args =
let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)
in (id_info, gen_code)
where
name = idName id
caffy = idCafInfo id
closure_label = mkClosureLabel name caffy
gen_code =
do { this_mod <- getModuleName
; when (platformOS (targetPlatform dflags) == OSMinGW32) $
MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )
; ASSERT( args `lengthIs` countConRepArgs con ) return ()
; let
(tot_wds,
ptr_wds,
nv_args_w_offsets) =
mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args)
mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
mk_payload (FieldOff arg _) = do
CmmLit lit <- getArgAmode arg
return lit
nonptr_wds = tot_wds ptr_wds
info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds
; payload <- mapM mk_payload nv_args_w_offsets
; let closure_rep = mkStaticClosureFields
dflags
info_tbl
dontCareCCS
caffy
payload
; emitDataLits closure_label closure_rep
; return () }
buildDynCon :: Id
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon binder actually_bound cc con args
= do dflags <- getDynFlags
buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args
buildDynCon' :: DynFlags
-> Platform
-> Id -> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon' dflags _ binder _ _cc con []
| isNullaryRepDataCon con
= return (litIdInfo dflags binder (mkConLFInfo con)
(CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
return mkNop)
buildDynCon' dflags platform binder _ _cc con [arg]
| maybeIntLikeCon con
, platformOS platform /= OSMinGW32 || not (positionIndependent dflags)
, NonVoid (StgLitArg (MachInt val)) <- arg
, val <= fromIntegral (mAX_INTLIKE dflags)
, val >= fromIntegral (mIN_INTLIKE dflags)
= do { let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE")
val_int = fromIntegral val :: Int
offsetW = (val_int mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1)
intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW
; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode
, return mkNop) }
buildDynCon' dflags platform binder _ _cc con [arg]
| maybeCharLikeCon con
, platformOS platform /= OSMinGW32 || not (positionIndependent dflags)
, NonVoid (StgLitArg (MachChar val)) <- arg
, let val_int = ord val :: Int
, val_int <= mAX_CHARLIKE dflags
, val_int >= mIN_CHARLIKE dflags
= do { let charlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit "stg_CHARLIKE")
offsetW = (val_int mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1)
charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW
; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode
, return mkNop) }
buildDynCon' dflags _ binder actually_bound ccs con args
= do { (id_info, reg) <- rhsIdInfo binder lf_info
; return (id_info, gen_code reg)
}
where
lf_info = mkConLFInfo con
gen_code reg
= do { let (tot_wds, ptr_wds, args_w_offsets)
= mkVirtConstrOffsets dflags (addArgReps args)
nonptr_wds = tot_wds ptr_wds
info_tbl = mkDataConInfoTable dflags con False
ptr_wds nonptr_wds
; let ticky_name | actually_bound = Just binder
| otherwise = Nothing
; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info
use_cc blame_cc args_w_offsets
; return (mkRhsInit dflags reg lf_info hp_plus_n) }
where
use_cc
| isCurrentCCS ccs = curCCS
| otherwise = panic "buildDynCon: non-current CCS not implemented"
blame_cc = use_cc
bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
bindConArgs (DataAlt con) base args
= ASSERT(not (isUnboxedTupleCon con))
do dflags <- getDynFlags
let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)
tag = tagForCon dflags con
bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)
bind_arg (arg@(NonVoid b), offset)
| isDeadBinder b =
return Nothing
| otherwise = do
emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag
Just <$> bindArgToReg arg
mapMaybeM bind_arg args_w_offsets
bindConArgs _other_con _base args
= ASSERT( null args ) return []