%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[CgConTbls]{Info tables and update bits for constructors}
\begin{code}
-#include "HsVersions.h"
-
-module CgConTbls (
- genStaticConBits,
+module CgConTbls ( genStaticConBits ) where
- -- and to complete the interface...
- TCE(..), UniqFM, CompilationInfo, AbstractC
- ) where
-
-import Pretty -- ToDo: rm (debugging)
-import Outputable
+#include "HsVersions.h"
import AbsCSyn
import CgMonad
-import AbsUniType ( getTyConDataCons, kindFromType,
- maybeIntLikeTyCon,
- mkSpecTyCon, isLocalSpecTyCon,
- TyVarTemplate, TyCon, Class,
- TauType(..), UniType, ThetaType(..)
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import CgHeapery ( heapCheck, allocDynClosure )
-import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg,
- mkLiveRegsBitMask,
- CtrlReturnConvention(..),
- DataReturnConvention(..)
- )
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts )
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
-import CgUsages ( getHpRelOffset )
-import CLabelInfo ( mkConEntryLabel, mkStaticConEntryLabel,
- --UNUSED: mkInfoTableLabel,
- mkClosureLabel, --UNUSED: mkConUpdCodePtrUnvecLabel,
- mkConUpdCodePtrVecLabel, mkStdUpdCodePtrVecLabel,
- mkStdUpdVecTblLabel, CLabel
- )
-import ClosureInfo ( layOutStaticClosure, layOutDynCon,
- closureSizeWithoutFixedHdr, closurePtrsSize,
- fitsMinUpdSize, mkConLFInfo, layOutPhantomClosure,
- infoTableLabelFromCI, dataConLiveness
- )
-import CmdLineOpts ( GlobalSwitch(..) )
-import FiniteMap
-import Id ( getDataConTag, getDataConSig, getDataConTyCon,
- mkSameSpecCon,
- getDataConArity, fIRST_TAG, ConTag(..),
- DataCon(..)
- )
-import CgCompInfo ( uF_UPDATEE )
-import Maybes ( maybeToBool, Maybe(..) )
-import PrimKind ( getKindSize, retKindSize )
-import CostCentre
-import UniqSet -- ( emptyUniqSet, UniqSet(..) )
-import TCE ( rngTCE, TCE(..), UniqFM )
-import Util
+import ClosureInfo ( layOutStaticConstr, layOutDynConstr, ClosureInfo )
+import DataCon ( DataCon, dataConName, dataConRepArgTys, isNullaryDataCon )
+import Name ( getOccName )
+import OccName ( occNameUserString )
+import TyCon ( tyConDataCons, isEnumerationTyCon, TyCon )
+import Type ( typePrimRep )
+import CmdLineOpts
\end{code}
For every constructor we generate the following info tables:
- A static info table, for static instances of the constructor,
-
- For constructors which return in registers (and only them),
- an "inregs" info table. This info table is rather emaciated;
- it only contains update code and tag.
+ A static info table, for static instances of the constructor,
Plus:
Possible info tables for constructor con:
\begin{description}
-\item[@con_info@:]
+\item[@_con_info@:]
Used for dynamically let(rec)-bound occurrences of
the constructor, and for updates. For constructors
which are int-like, char-like or nullary, when GC occurs,
the closure tries to get rid of itself.
-\item[@con_inregs_info@:]
-Used when returning a new constructor in registers.
-Only for return-in-regs constructors.
-Macro: @INREGS_INFO_TABLE@.
-
-\item[@con_static_info@:]
+\item[@_static_info@:]
Static occurrences of the constructor
macro: @STATIC_INFO_TABLE@.
\end{description}
-For zero-arity constructors, \tr{con}, we also generate a static closure:
-\begin{description}
-\item[@con_closure@:]
-A single static copy of the (zero-arity) constructor itself.
-\end{description}
+For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure;
+it's place is taken by the top level defn of the constructor.
For charlike and intlike closures there is a fixed array of static
closures predeclared.
\begin{code}
genStaticConBits :: CompilationInfo -- global info about the compilation
-> [TyCon] -- tycons to generate
- -> FiniteMap TyCon [[Maybe UniType]]
- -- tycon specialisation info
-> AbstractC -- output
-genStaticConBits comp_info gen_tycons tycon_specs
+genStaticConBits comp_info gen_tycons
= -- for each type constructor:
-- grab all its data constructors;
-- for each one, generate an info table
-- ToDo: for tycons and specialisations which are not
-- declared in this module we must ensure that the
-- 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 ]
- `mkAbsCStmts`
- mkAbstractCs [ mkAbstractCs [ gen_for_spec_tycon tc spec
- | spec <- specs ]
- | (tc, specs) <- fmToList tycon_specs,
- isLocalSpecTyCon (sw_chkr CompilingPrelude) tc
- ]
+ 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) data_cons)
- `mkAbsCStmts` maybe_tycon_vtbl
-
- where
- data_cons = getTyConDataCons tycon
- tycon_upd_label = mkStdUpdVecTblLabel tycon
-
- maybe_tycon_vtbl =
- case ctrlReturnConvAlg tycon of
- UnvectoredReturn 1 -> CRetUnVector tycon_upd_label
- (mk_upd_label tycon (head data_cons))
- UnvectoredReturn _ -> AbsCNop
- VectoredReturn _ -> CFlatRetVector tycon_upd_label
- (map (mk_upd_label tycon) data_cons)
- ------------------
- gen_for_spec_tycon :: TyCon -> [Maybe UniType] -> AbstractC
-
- gen_for_spec_tycon tycon ty_maybes
- = mkAbstractCs (map (genConInfo comp_info tycon) spec_data_cons)
- `mkAbsCStmts`
- maybe_spec_tycon_vtbl
- where
- data_cons = getTyConDataCons tycon
-
- spec_tycon = mkSpecTyCon tycon ty_maybes
- spec_data_cons = map (mkSameSpecCon ty_maybes) data_cons
-
- spec_tycon_upd_label = mkStdUpdVecTblLabel spec_tycon
-
- maybe_spec_tycon_vtbl =
- case ctrlReturnConvAlg spec_tycon of
- UnvectoredReturn 1 -> CRetUnVector spec_tycon_upd_label
- (mk_upd_label spec_tycon (head spec_data_cons))
- UnvectoredReturn _ -> AbsCNop
- VectoredReturn _ -> CFlatRetVector spec_tycon_upd_label
- (map (mk_upd_label spec_tycon) spec_data_cons)
- ------------------
- mk_upd_label tycon con
- = CLbl
- (case (dataReturnConvAlg isw_chkr con) of
- ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
- ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag)
- CodePtrKind
- where
- tag = getDataConTag con
-
- ------------------
- (MkCompInfo sw_chkr isw_chkr _) = comp_info
+ 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 -> Id -> AbstractC
+genConInfo :: CompilationInfo -> DataCon -> AbstractC
-genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
- = mkAbstractCs [
- CSplitMarker,
- inregs_upd_maybe,
+genConInfo comp_info data_con
+ = -- Order of things is to reduce forward references
+ mkAbstractCs [if opt_EnsureSplittableC then CSplitMarker else AbsCNop,
closure_code,
- static_code,
- closure_maybe]
- -- Order of things is to reduce forward references
+ static_code]
where
- (closure_info, body_code) = mkConCodeAndInfo isw_chkr data_con
+ (closure_info, body_code) = mkConCodeAndInfo 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_ci,_) = layOutStaticClosure data_con kindFromType arg_tys (mkConLFInfo data_con)
-
- body = (initC comp_info (
- profCtrC SLIT("ENT_CON") [CReg node] `thenC`
- body_code))
+ (static_ci,_) = layOutStaticConstr con_name data_con typePrimRep arg_tys
- entry_addr = CLbl entry_label CodePtrKind
- con_descr = _UNPK_ (getOccurrenceName data_con)
+ static_body = initC comp_info (
+ profCtrC FSLIT("TICK_ENT_STATIC_CON") [CReg node] `thenC`
+ ldv_enter_and_body_code)
- closure_code = CClosureInfoAndCode closure_info body Nothing
- stdUpd con_descr
- (dataConLiveness isw_chkr closure_info)
- static_code = CClosureInfoAndCode static_ci body Nothing
- stdUpd con_descr
- (dataConLiveness isw_chkr static_ci)
+ closure_body = initC comp_info (
+ profCtrC FSLIT("TICK_ENT_DYN_CON") [CReg node] `thenC`
+ ldv_enter_and_body_code)
- inregs_upd_maybe = genPhantomUpdInfo comp_info tycon data_con
+ ldv_enter_and_body_code = ldvEnter `thenC` body_code
- stdUpd = CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrKind
+ con_descr = occNameUserString (getOccName data_con)
- tag = getDataConTag data_con
+ -- Don't need any dynamic closure code for zero-arity constructors
+ closure_code = if zero_arity_con then
+ AbsCNop
+ else
+ CClosureInfoAndCode closure_info closure_body Nothing con_descr
- cost_centre = mkCCostCentre dontCareCostCentre -- not worried about static data costs
+ static_code = CClosureInfoAndCode static_ci static_body Nothing con_descr
- -- For zero-arity data constructors, or, more accurately,
- -- those which only have VoidKind args (or none):
- -- We make the closure too (not just info tbl), so that we can share
- -- one copy throughout.
- closure_maybe = -- OLD: if con_arity /= 0 then
- if not (all zero_size arg_tys) then
- AbsCNop
- else
- CStaticClosure closure_label -- Label for closure
- static_ci -- Info table
- cost_centre
- [{-No args! A slight lie for constrs with VoidKind args-}]
+ zero_arity_con = isNullaryDataCon data_con
+ -- We used to check that all the arg-sizes were zero, but we don't
+ -- really have any constructors with only zero-size args, and it's
+ -- just one more thing to go wrong.
- zero_size arg_ty = getKindSize (kindFromType arg_ty) == 0
-
- (_,_,arg_tys,_) = getDataConSig data_con
- con_arity = getDataConArity data_con
- entry_label = mkConEntryLabel data_con
- closure_label = mkClosureLabel data_con
+ arg_tys = dataConRepArgTys data_con
+ con_name = dataConName data_con
\end{code}
\begin{code}
-mkConCodeAndInfo :: IntSwitchChecker
- -> Id -- Data constructor
+mkConCodeAndInfo :: DataCon -- Data constructor
-> (ClosureInfo, Code) -- The info table
-mkConCodeAndInfo isw_chkr con
- = case (dataReturnConvAlg isw_chkr con) of
+mkConCodeAndInfo con
+ = let
+ arg_tys = dataConRepArgTys con
- ReturnInRegs regs ->
- let
- (closure_info, regs_w_offsets)
- = layOutDynCon con kindFromMagicId regs
+ (closure_info, arg_things)
+ = layOutDynConstr (dataConName con) con typePrimRep arg_tys
- body_code
- = profCtrC SLIT("RET_OLD_IN_REGS") [mkIntCLit (length regs_w_offsets)] `thenC`
+ body_code
+ = -- NB: We don't set CC when entering data (WDP 94/06)
+ profCtrC FSLIT("TICK_RET_OLD")
+ [mkIntCLit (length arg_things)] `thenC`
- performReturn (mkAbstractCs (map move_to_reg regs_w_offsets))
- (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
- emptyUniqSet{-no live vars-}
- in
- (closure_info, body_code)
-
- ReturnInHeap ->
- let
- (_, _, arg_tys, _) = getDataConSig con
-
- (closure_info, arg_things)
- = layOutDynCon con kindFromType arg_tys
-
- body_code
- = -- OLD: We don't set CC when entering data any more (WDP 94/06)
- -- lexCostCentreC "ENTER_CC_DCL" [CReg node] `thenC`
- profCtrC SLIT("RET_OLD_IN_HEAP") [mkIntCLit (length arg_things)] `thenC`
-
- performReturn AbsCNop -- Ptr to thing already in Node
- (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
- emptyUniqSet{-no live vars-}
+ performReturn AbsCNop -- Ptr to thing already in Node
+ (mkStaticAlgReturnCode con)
in
(closure_info, body_code)
-
- where
- move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
- move_to_reg (reg, offset)
- = CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg))
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgConTbls-updates]{Generating update bits for constructors}
-%* *
-%************************************************************************
-
-Generate the "phantom" info table and update code, iff the constructor returns in regs
-
-\begin{code}
-
-genPhantomUpdInfo :: CompilationInfo -> TyCon -> Id{-data con-} -> AbstractC
-
-genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
- = case (dataReturnConvAlg isw_chkr data_con) of
-
- ReturnInHeap -> --OLD: pprTrace "NoPhantom: " (ppr PprDebug data_con) $
- AbsCNop -- No need for a phantom update
-
- ReturnInRegs regs ->
- --OLD: pprTrace "YesPhantom! " (ppr PprDebug data_con) $
- let
- phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing
- upd_code con_descr
- (dataConLiveness isw_chkr phantom_ci)
-
- phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
-
- con_descr = _UNPK_ (getOccurrenceName data_con)
-
- con_arity = getDataConArity data_con
-
- upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return)
- upd_label = mkConUpdCodePtrVecLabel tycon tag
- tag = getDataConTag data_con
-
- updatee = CVal (SpBRel 0 (-uF_UPDATEE)) PtrKind
-
- perform_return = mkAbstractCs
- [
- CMacroStmt POP_STD_UPD_FRAME [],
- CReturn (CReg RetReg) return_info
- ]
-
- return_info =
- -- OLD: pprTrace "ctrlReturn6:" (ppr PprDebug tycon) (
- case (ctrlReturnConvAlg tycon) of
- UnvectoredReturn _ -> DirectReturn
- VectoredReturn _ -> StaticVectoredReturn (tag - fIRST_TAG)
- -- )
-
- -- Determine cost centre for the updated closures CC (and allocation)
- -- CCC for lexical (now your only choice)
- use_cc = CReg CurCostCentre -- what to put in the closure
- blame_cc = use_cc -- who to blame for allocation
-
- do_move (reg, virt_offset) =
- CAssign (CVal (NodeRel virt_offset) (kindFromMagicId reg)) (CReg reg)
-
-
- -- Code for building a new constructor in place over the updatee
- overwrite_code
- = profCtrC SLIT("UPD_CON_IN_PLACE")
- [mkIntCLit (length regs_w_offsets)] `thenC`
- absC (mkAbstractCs
- [
- CAssign (CReg node) updatee,
-
- -- Tell the storage mgr that we intend to update in place
- -- This may (in complicated mgrs eg generational) cause gc,
- -- and it may modify Node to point to another place to
- -- actually update into.
- CMacroStmt upd_inplace_macro [liveness_mask],
-
- -- Initialise the closure pointed to by node
- CInitHdr closure_info (NodeRel zeroOff) use_cc True,
- mkAbstractCs (map do_move regs_w_offsets),
- if con_arity /= 0 then
- CAssign (CReg infoptr) (CLbl info_label DataPtrKind)
- else
- AbsCNop
- ])
-
- upd_inplace_macro = if closurePtrsSize closure_info == 0
- then UPD_INPLACE_NOPTRS
- else UPD_INPLACE_PTRS
-
- -- Code for allocating a new constructor in the heap
- alloc_code
- = let
- amodes_w_offsets = [ (CReg r, o) | (r,o) <- regs_w_offsets ]
- in
- -- Allocate and build closure specifying upd_new_w_regs
- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
- `thenFC` \ hp_offset ->
- getHpRelOffset hp_offset `thenFC` \ hp_rel ->
- let
- amode = CAddr hp_rel
- in
- profCtrC SLIT("UPD_CON_IN_NEW")
- [mkIntCLit (length amodes_w_offsets)] `thenC`
- absC (mkAbstractCs
- [ CMacroStmt UPD_IND [updatee, amode],
- CAssign (CReg node) amode,
- CAssign (CReg infoptr) (CLbl info_label DataPtrKind)
- ])
-
- (closure_info, regs_w_offsets) = layOutDynCon data_con kindFromMagicId regs
- info_label = infoTableLabelFromCI closure_info
- liveness_mask = mkIntCLit (mkLiveRegsBitMask (node:regs))
-
- build_closure =
- if fitsMinUpdSize closure_info then
- initC comp_info overwrite_code
- else
- initC comp_info (heapCheck regs False alloc_code)
-
- in CClosureUpdInfo phantom_itbl
-
\end{code}
-