import CgProf ( mkCCostCentreStack, ldvEnter, curCCS )
import CgTicky
import CgInfoTbls ( emitClosureCodeAndInfoTable, dataConTagZ )
-import CLabel ( mkClosureLabel, mkRtsDataLabel, mkClosureTblLabel )
+import CLabel
import ClosureInfo ( mkConLFInfo, mkLFArgument )
import CmmUtils ( mkLblExpr )
import Cmm
currentCCS )
import Constants ( mIN_INTLIKE, mAX_INTLIKE, mIN_CHARLIKE, mAX_CHARLIKE )
import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, tyConName )
-import DataCon ( DataCon, dataConRepArgTys, isNullaryDataCon,
+import DataCon ( DataCon, dataConRepArgTys, isNullaryRepDataCon,
isUnboxedTupleCon, dataConWorkId,
dataConName, dataConRepArity
)
-> [StgArg] -- Args
-> FCode (Id, CgIdInfo)
cgTopRhsCon id con args
- = ASSERT( not (isDllConApp con args) )
- ASSERT( args `lengthIs` dataConRepArity con )
- do { -- LAY IT OUT
+ = do {
+ ; hmods <- getHomeModules
+#if mingw32_TARGET_OS
+ -- Windows DLLs have a problem with static cross-DLL refs.
+ ; ASSERT( not (isDllConApp hmods con args) ) return ()
+#endif
+ ; ASSERT( args `lengthIs` dataConRepArity con ) return ()
+
+ -- LAY IT OUT
; amodes <- getArgAmodes args
; let
name = idName id
lf_info = mkConLFInfo con
- closure_label = mkClosureLabel name
+ closure_label = mkClosureLabel hmods name
caffy = any stgArgHasCafRefs args
- (closure_info, amodes_w_offsets) = layOutStaticConstr con amodes
+ (closure_info, amodes_w_offsets) = layOutStaticConstr hmods con amodes
closure_rep = mkStaticClosureFields
closure_info
dontCareCCS -- Because it's static data
\begin{code}
buildDynCon binder cc con []
- = returnFC (stableIdInfo binder
- (mkLblExpr (mkClosureLabel (dataConName con)))
+ = do hmods <- getHomeModules
+ returnFC (stableIdInfo binder
+ (mkLblExpr (mkClosureLabel hmods (dataConName con)))
(mkConLFInfo con))
\end{code}
\begin{code}
buildDynCon binder ccs con args
- = do { hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
+ = do {
+ ; hmods <- getHomeModules
+ ; let
+ (closure_info, amodes_w_offsets) = layOutDynConstr hmods con args
+
+ ; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
; returnFC (heapIdInfo binder hp_off lf_info) }
where
lf_info = mkConLFInfo con
- (closure_info, amodes_w_offsets) = layOutDynConstr con args
use_cc -- cost-centre to stick in the object
| currentOrSubsumedCCS ccs = curCCS
\begin{code}
bindConArgs :: DataCon -> [Id] -> Code
bindConArgs con args
- = ASSERT(not (isUnboxedTupleCon con))
- mapCs bind_arg args_w_offsets
- where
- bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg)
- (_, args_w_offsets) = layOutDynConstr con (addIdReps args)
+ = do hmods <- getHomeModules
+ let
+ bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg)
+ (_, args_w_offsets) = layOutDynConstr hmods con (addIdReps args)
+ --
+ ASSERT(not (isUnboxedTupleCon con)) return ()
+ mapCs bind_arg args_w_offsets
\end{code}
Unboxed tuples are handled slightly differently - the object is
-- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
; extra <-
if isEnumerationTyCon tycon then do
- tbl <- getCmm (emitRODataLits (mkClosureTblLabel
+ tbl <- getCmm (emitRODataLits (mkLocalClosureTableLabel
(tyConName tycon))
- [ CmmLabel (mkClosureLabel (dataConName con))
+ [ CmmLabel (mkLocalClosureLabel (dataConName con))
| con <- tyConDataCons tycon])
return [tbl]
else
cgDataCon :: DataCon -> Code
cgDataCon data_con
= do { -- Don't need any dynamic closure code for zero-arity constructors
- whenC (not (isNullaryDataCon data_con))
+ hmods <- getHomeModules
+
+ ; let
+ -- To allow the debuggers, interpreters, etc to cope with
+ -- static data structures (ie those built at compile
+ -- time), we take care that info-table contains the
+ -- information we need.
+ (static_cl_info, _) =
+ layOutStaticConstr hmods data_con arg_reps
+
+ (dyn_cl_info, arg_things) =
+ layOutDynConstr hmods data_con arg_reps
+
+ emit_info cl_info ticky_code
+ = do { code_blks <- getCgStmts the_code
+ ; emitClosureCodeAndInfoTable cl_info [] code_blks }
+ where
+ the_code = do { ticky_code
+ ; ldvEnter (CmmReg nodeReg)
+ ; body_code }
+
+ arg_reps :: [(CgRep, Type)]
+ arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con]
+
+ body_code = do {
+ -- NB: We don't set CC when entering data (WDP 94/06)
+ tickyReturnOldCon (length arg_things)
+ ; performReturn (emitKnownConReturnCode data_con) }
+ -- noStmts: Ptr to thing already in Node
+
+ ; whenC (not (isNullaryRepDataCon data_con))
(emit_info dyn_cl_info tickyEnterDynCon)
-- Dynamic-Closure first, to reduce forward references
; emit_info static_cl_info tickyEnterStaticCon }
where
- emit_info cl_info ticky_code
- = do { code_blks <- getCgStmts the_code
- ; emitClosureCodeAndInfoTable cl_info [] code_blks }
- where
- the_code = do { ticky_code
- ; ldvEnter (CmmReg nodeReg)
- ; body_code }
-
- arg_reps :: [(CgRep, Type)]
- arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con]
-
- -- To allow the debuggers, interpreters, etc to cope with static
- -- data structures (ie those built at compile time), we take care that
- -- info-table contains the information we need.
- (static_cl_info, _) = layOutStaticConstr data_con arg_reps
- (dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps
-
- body_code = do { -- NB: We don't set CC when entering data (WDP 94/06)
- tickyReturnOldCon (length arg_things)
- ; performReturn (emitKnownConReturnCode data_con) }
- -- noStmts: Ptr to thing already in Node
\end{code}
projects / ghc-hetmet.git / blobdiff