#include "HsVersions.h"
import AbsCSyn
+import StgSyn
import CgMonad
import AbsCUtils ( mkAbstractCs, mkAbsCStmts )
+import CostCentre ( noCCS )
+import CgCon ( cgTopRhsCon )
+import CgClosure ( cgTopRhsClosure )
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
-import ClosureInfo ( layOutStaticConstr, layOutDynConstr, ClosureInfo )
-import DataCon ( DataCon, dataConName, dataConRepArgTys, isNullaryDataCon )
+import ClosureInfo ( layOutStaticConstr, layOutDynConstr, mkClosureLFInfo, ClosureInfo )
+import DataCon ( DataCon, dataConName, dataConRepArgTys, dataConId, isNullaryDataCon )
+import Id ( mkTemplateLocals )
import Name ( getOccName )
import OccName ( occNameUserString )
import TyCon ( tyConDataCons, isEnumerationTyCon, TyCon )
import Type ( typePrimRep )
+import BasicTypes ( TopLevelFlag(..) )
+import Outputable
\end{code}
For every constructor we generate the following info tables:
-- C labels are local to this module i.e. static
-- since they may be duplicated in other modules
- mkAbstractCs [ gen_for_tycon tc | tc <- gen_tycons ]
+ mkAbstractCs [ gen_for_tycon tc `mkAbsCStmts` enum_closure_table tc
+ | tc <- gen_tycons ]
where
gen_for_tycon :: TyCon -> AbstractC
- gen_for_tycon tycon
- = mkAbstractCs (map (genConInfo comp_info tycon) (tyConDataCons tycon))
- `mkAbsCStmts` (
- -- after the con decls, so we don't need to declare the constructor labels
- if (isEnumerationTyCon tycon)
- then CClosureTbl tycon
- else AbsCNop
- )
+ gen_for_tycon tycon = mkAbstractCs [ genConInfo comp_info data_con
+ | data_con <- tyConDataCons tycon ]
+
+ enum_closure_table tycon
+ | isEnumerationTyCon tycon = CClosureTbl tycon
+ | otherwise = AbsCNop
+ -- Put the table after the data constructor decls, because the
+ -- datatype closure table (for enumeration types)
+ -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
\end{code}
+
%************************************************************************
%* *
\subsection[CgConTbls-info-tables]{Generating info tables for constructors}
static closure, for a constructor.
\begin{code}
-genConInfo :: CompilationInfo -> TyCon -> DataCon -> AbstractC
+genConInfo :: CompilationInfo -> DataCon -> AbstractC
-genConInfo comp_info tycon data_con
- = mkAbstractCs [
- CSplitMarker,
+genConInfo comp_info data_con
+ = -- Order of things is to reduce forward references
+ mkAbstractCs [CSplitMarker,
closure_code,
- static_code]
- -- Order of things is to reduce forward references
+ static_code,
+ wrkr_code]
where
(closure_info, body_code) = mkConCodeAndInfo data_con
-- info-table contains the information we need.
(static_ci,_) = layOutStaticConstr con_name data_con typePrimRep arg_tys
- body = (initC comp_info (
+ body = initC comp_info (
profCtrC SLIT("TICK_ENT_CON") [CReg node] `thenC`
- body_code))
+ body_code)
+ wrkr_code = initC comp_info (cgWorker data_con `thenFC` \ _ -> returnFC ())
con_descr = occNameUserString (getOccName data_con)
-- Don't need any dynamic closure code for zero-arity constructors
in
(closure_info, body_code)
\end{code}
+
+For a constructor C, make a binding
+
+ $wC = \x y -> $wC x y
+
+i.e. a curried constructor that allocates. This means that we can treat
+the worker for a constructor like any other function in the rest of the compiler.
+
+\begin{code}
+cgWorker data_con
+ | isNullaryDataCon data_con
+ = cgTopRhsCon work_id data_con []
+
+ | otherwise
+ = cgTopRhsClosure work_id
+ noCCS noBinderInfo NoSRT
+ arg_ids rhs
+ lf_info
+ where
+ work_id = dataConId data_con
+ arg_ids = mkTemplateLocals (dataConRepArgTys data_con)
+ rhs = StgConApp data_con [StgVarArg id | id <- arg_ids]
+ lf_info = mkClosureLFInfo work_id TopLevel [{-no fvs-}] ReEntrant arg_ids
+\end{code}
}
where
data_tycons = filter isDataTyCon tycons
-
cinfo = MkCompInfo mod_name
\end{code}
`thenFC` \ (id, _, _) -> returnFC id
(id':_) -> returnFC id'
--- if we're splitting the object, we need to globalise all the top-level names
+-- If we're splitting the object, we need to globalise all the top-level names
-- (and then make sure we only use the globalised one in any C label we use
-- which refers to this name).
maybeGlobaliseId :: Id -> FCode Id
import Id ( idType, idInfo, idName, isExportedId,
idSpecialisation, idUnique, isDataConWrapId,
mkVanillaGlobal, mkGlobalId, isLocalId,
- hasNoBinding, mkUserLocal, isGlobalId, globalIdDetails,
+ isDataConId, mkUserLocal, isGlobalId, globalIdDetails,
idNewDemandInfo, setIdNewDemandInfo,
idNewStrictness_maybe, setIdNewStrictness
)
-- in interface files, because they are needed by importing modules when
-- using the compilation manager
- -- We keep "hasNoBinding" Ids, notably constructor workers,
+ -- We keep constructor workers,
-- because they won't appear in the bindings from which final_ids are derived!
- keep_it (AnId id) = hasNoBinding id -- Remove all Ids except constructor workers
+ keep_it (AnId id) = isDataConId id -- Remove all Ids except constructor workers
keep_it other = True -- Keep all TyCons and Classes
\end{code}
-- NB: f_arity is only consulted for LetBound things
f_arity = case how_bound of
LetBound _ arity -> arity
+ ImportBound -> idArity f
+
+ saturated = f_arity <= n_val_args
fun_occ
- | not_letrec_bound = noBinderInfo -- Uninteresting variable
- | f_arity > 0 && f_arity <= n_val_args = stgSatOcc -- Saturated or over-saturated function call
- | otherwise = stgUnsatOcc -- Unsaturated function or thunk
+ | not_letrec_bound = noBinderInfo -- Uninteresting variable
+ | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
+ | otherwise = stgUnsatOcc -- Unsaturated function or thunk
fun_escs
| not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
res_ty = exprType (mkApps (Var f) args)
app = case globalIdDetails f of
- DataConId dc -> StgConApp dc args'
- PrimOpId op -> StgOpApp (StgPrimOp op) args' res_ty
- FCallId call -> StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
- _other -> StgApp f args'
+ DataConId dc | saturated -> StgConApp dc args'
+ PrimOpId op -> ASSERT( saturated )
+ StgOpApp (StgPrimOp op) args' res_ty
+ FCallId call -> ASSERT( saturated )
+ StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
+ _other -> StgApp f args'
in
returnLne (
addLiveVar :: LiveInfo -> Id -> LiveInfo
addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)
-deleteLiveVar :: LiveInfo -> Id -> LiveInfo
-deleteLiveVar (lvs, cafs) id = (lvs `delVarSet` id, cafs)
-
unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)
-unionLiveInfos :: [LiveInfo] -> LiveInfo
-unionLiveInfos lvs = foldr unionLiveInfo emptyLiveInfo lvs
-
mkSRT :: LiveInfo -> SRT
mkSRT (_, cafs) = SRTEntries cafs
-- we look up just once when we encounter the occurrence.
-- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
-- Imported Ids without CAF refs are simply
- -- not put in the FreeVarsInfo for an expression;
- -- see singletonFVInfo
+ -- not put in the FreeVarsInfo for an expression.
+ -- See singletonFVInfo and freeVarsToLiveVars
--
- -- StgBinderInfo
+ -- StgBinderInfo records how it occurs; notably, we
+ -- are interested in whether it only occurs in saturated
+ -- applications, because then we don't need to build a
+ -- curried version.
-- If f is mapped to noBinderInfo, that means
-- that f *is* mentioned (else it wouldn't be in the
-- IdEnv at all), but perhaps in an unsaturated applications.
projects / ghc-hetmet.git / commitdiff