X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgConTbls.lhs;h=37ced1ee2b5e6e860fb1cb9b717855deea740aca;hb=553e90d9a32ee1b1809430f260c401cc4169c6c7;hp=61a75017d3a44c4c232131711d28d888fc7105d2;hpb=68a1f0233996ed79824d11d946e9801473f6946c;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index 61a7501..37ced1e 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -1,72 +1,27 @@ % -% (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, - 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, dataConRepArgTys, isNullaryDataCon ) +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: @@ -83,28 +38,20 @@ info & @GEN_INFO_TABLE@& GENish (hence bigger than or equal to @MIN_UPD_SIZ 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. @@ -112,11 +59,9 @@ closures predeclared. \begin{code} genStaticConBits :: CompilationInfo -- global info about the compilation -> [TyCon] -- tycons to generate - -> FiniteMap TyCon [(Bool, [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 @@ -129,67 +74,22 @@ genStaticConBits comp_info gen_tycons tycon_specs -- 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 - | (imported_spec, spec) <- specs, - -- no code generated if spec is imported - not imported_spec - ] - | (tc, specs) <- fmToList tycon_specs ] + 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 spec_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} @@ -200,230 +100,64 @@ Generate the entry code, info tables, and (for niladic constructor) the 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)) - - entry_addr = CLbl entry_label CodePtrKind - con_descr = _UNPK_ (getOccurrenceName data_con) + (static_ci,_) = layOutStaticConstr data_con typePrimRep arg_tys - 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) + static_body = initC comp_info ( + profCtrC FSLIT("TICK_ENT_STATIC_CON") [CReg node] `thenC` + ldv_enter_and_body_code) - inregs_upd_maybe = genPhantomUpdInfo comp_info tycon data_con + closure_body = initC comp_info ( + profCtrC FSLIT("TICK_ENT_DYN_CON") [CReg node] `thenC` + ldv_enter_and_body_code) - stdUpd = CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrKind + ldv_enter_and_body_code = ldvEnter `thenC` body_code - 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 - cost_centre = mkCCostCentre dontCareCostCentre -- not worried about static data costs + static_code = CClosureInfoAndCode static_ci static_body - -- 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 \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 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} -