X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgConTbls.lhs;h=29a89a57f4c71ae8f1e2cf73dad85d6bc51e6291;hb=5cf27e8f1731c52fe63a5b9615f927484164c61b;hp=22bfa737a9bf98cff9e116a8e0cdc8894e913972;hpb=10521d8418fd3a1cf32882718b5bd28992db36fd;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index 22bfa73..29a89a5 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -1,71 +1,59 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \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 +import Ubiq{-uitous-} 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 AbsCUtils ( mkAbsCStmts, mkAbstractCs, magicIdPrimRep ) +import CgCompInfo ( uF_UPDATEE ) import CgHeapery ( heapCheck, allocDynClosure ) -import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg, - mkLiveRegsBitMask, +import CgRetConv ( mkLiveRegsMask, + dataReturnConvAlg, ctrlReturnConvAlg, CtrlReturnConvention(..), DataReturnConvention(..) ) import CgTailCall ( performReturn, mkStaticAlgReturnCode ) import CgUsages ( getHpRelOffset ) -import CLabelInfo ( mkConEntryLabel, mkStaticConEntryLabel, - --UNUSED: mkInfoTableLabel, - mkClosureLabel, --UNUSED: mkConUpdCodePtrUnvecLabel, - mkConUpdCodePtrVecLabel, mkStdUpdCodePtrVecLabel, - mkStdUpdVecTblLabel, CLabel +import CLabel ( mkConEntryLabel, mkClosureLabel, + mkConUpdCodePtrVecLabel, + mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel ) import ClosureInfo ( layOutStaticClosure, layOutDynCon, - closureSizeWithoutFixedHdr, closurePtrsSize, - fitsMinUpdSize, mkConLFInfo, layOutPhantomClosure, + layOutPhantomClosure, closurePtrsSize, + fitsMinUpdSize, mkConLFInfo, infoTableLabelFromCI, dataConLiveness ) -import CmdLineOpts ( GlobalSwitch(..) ) -import FiniteMap -import Id ( getDataConTag, getDataConSig, getDataConTyCon, - mkSameSpecCon, - getDataConArity, fIRST_TAG, ConTag(..), - DataCon(..) +import CostCentre ( dontCareCostCentre ) +import FiniteMap ( fmToList ) +import HeapOffs ( zeroOff, VirtualHeapOffset(..) ) +import Id ( dataConTag, dataConSig, + dataConArity, fIRST_TAG, + emptyIdSet, + GenId{-instance NamedThing-} ) -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 Name ( getLocalName ) +import PrelInfo ( maybeIntLikeTyCon ) +import PrimRep ( getPrimRepSize, PrimRep(..) ) +import TyCon ( tyConDataCons, mkSpecTyCon ) +import Type ( typePrimRep ) +import Util ( panic ) + +mkSameSpecCon = panic "CgConTbls.mkSameSpecCon (ToDo)" \end{code} For every constructor we generate the following info tables: - A static info table, for static instances of the constructor, + A static info table, for static instances of the constructor, - For constructors which return in registers (and only them), + 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. @@ -91,7 +79,7 @@ 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. +Used when returning a new constructor in registers. Only for return-in-regs constructors. Macro: @INREGS_INFO_TABLE@. @@ -113,7 +101,7 @@ closures predeclared. \begin{code} genStaticConBits :: CompilationInfo -- global info about the compilation -> [TyCon] -- tycons to generate - -> FiniteMap TyCon [[Maybe UniType]] + -> FiniteMap TyCon [(Bool, [Maybe Type])] -- tycon specialisation info -> AbstractC -- output @@ -128,22 +116,24 @@ genStaticConBits comp_info gen_tycons tycon_specs -- 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 [ 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 ] where gen_for_tycon :: TyCon -> AbstractC gen_for_tycon tycon = mkAbstractCs (map (genConInfo comp_info tycon) data_cons) - `mkAbsCStmts` maybe_tycon_vtbl - + `mkAbsCStmts` + maybe_tycon_vtbl where - data_cons = getTyConDataCons tycon + data_cons = tyConDataCons tycon tycon_upd_label = mkStdUpdVecTblLabel tycon maybe_tycon_vtbl = @@ -151,17 +141,17 @@ genStaticConBits comp_info gen_tycons tycon_specs UnvectoredReturn 1 -> CRetUnVector tycon_upd_label (mk_upd_label tycon (head data_cons)) UnvectoredReturn _ -> AbsCNop - VectoredReturn _ -> CFlatRetVector tycon_upd_label + 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 -> [Maybe Type] -> AbstractC gen_for_spec_tycon tycon ty_maybes - = mkAbstractCs (map (genConInfo comp_info tycon) spec_data_cons) + = mkAbstractCs (map (genConInfo comp_info spec_tycon) spec_data_cons) `mkAbsCStmts` - maybe_spec_tycon_vtbl + maybe_spec_tycon_vtbl where - data_cons = getTyConDataCons tycon + data_cons = tyConDataCons tycon spec_tycon = mkSpecTyCon tycon ty_maybes spec_data_cons = map (mkSameSpecCon ty_maybes) data_cons @@ -178,15 +168,12 @@ genStaticConBits comp_info gen_tycons tycon_specs ------------------ mk_upd_label tycon con = CLbl - (case (dataReturnConvAlg isw_chkr con) of + (case (dataReturnConvAlg con) of ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag) - CodePtrKind + CodePtrRep where - tag = getDataConTag con - - ------------------ - (MkCompInfo sw_chkr isw_chkr _) = comp_info + tag = dataConTag con \end{code} %************************************************************************ @@ -201,7 +188,7 @@ static closure, for a constructor. \begin{code} genConInfo :: CompilationInfo -> TyCon -> Id -> AbstractC -genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con +genConInfo comp_info tycon data_con = mkAbstractCs [ CSplitMarker, inregs_upd_maybe, @@ -210,101 +197,98 @@ genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con closure_maybe] -- Order of things is to reduce forward references 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) + (static_ci,_) = layOutStaticClosure data_con typePrimRep 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) + entry_addr = CLbl entry_label CodePtrRep + con_descr = _UNPK_ (getLocalName data_con) closure_code = CClosureInfoAndCode closure_info body Nothing stdUpd con_descr - (dataConLiveness isw_chkr closure_info) + (dataConLiveness closure_info) static_code = CClosureInfoAndCode static_ci body Nothing stdUpd con_descr - (dataConLiveness isw_chkr static_ci) + (dataConLiveness static_ci) inregs_upd_maybe = genPhantomUpdInfo comp_info tycon data_con - stdUpd = CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrKind + stdUpd = CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrRep - tag = getDataConTag data_con + tag = dataConTag data_con cost_centre = mkCCostCentre dontCareCostCentre -- not worried about static data costs -- For zero-arity data constructors, or, more accurately, - -- those which only have VoidKind args (or none): + -- those which only have VoidRep 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 + closure_maybe = if not (all zero_size arg_tys) then AbsCNop - else + else CStaticClosure closure_label -- Label for closure static_ci -- Info table cost_centre - [{-No args! A slight lie for constrs with VoidKind args-}] + [{-No args! A slight lie for constrs with VoidRep args-}] - zero_size arg_ty = getKindSize (kindFromType arg_ty) == 0 + zero_size arg_ty = getPrimRepSize (typePrimRep arg_ty) == 0 - (_,_,arg_tys,_) = getDataConSig data_con - con_arity = getDataConArity data_con + (_,_,arg_tys,_) = dataConSig data_con + con_arity = dataConArity data_con entry_label = mkConEntryLabel data_con closure_label = mkClosureLabel data_con \end{code} \begin{code} -mkConCodeAndInfo :: IntSwitchChecker - -> Id -- Data constructor +mkConCodeAndInfo :: Id -- Data constructor -> (ClosureInfo, Code) -- The info table -mkConCodeAndInfo isw_chkr con - = case (dataReturnConvAlg isw_chkr con) of +mkConCodeAndInfo con + = case (dataReturnConvAlg con) of ReturnInRegs regs -> let (closure_info, regs_w_offsets) - = layOutDynCon con kindFromMagicId regs + = layOutDynCon con magicIdPrimRep regs body_code = profCtrC SLIT("RET_OLD_IN_REGS") [mkIntCLit (length regs_w_offsets)] `thenC` performReturn (mkAbstractCs (map move_to_reg regs_w_offsets)) (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-}) - emptyUniqSet{-no live vars-} + emptyIdSet{-no live vars-} in (closure_info, body_code) - + ReturnInHeap -> let - (_, _, arg_tys, _) = getDataConSig con + (_, _, arg_tys, _) = dataConSig con (closure_info, arg_things) - = layOutDynCon con kindFromType arg_tys + = layOutDynCon con typePrimRep 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` + = -- NB: We don't set CC when entering data (WDP 94/06) 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-} + (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-}) + emptyIdSet{-no live vars-} 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} + = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg)) +\end{code} %************************************************************************ %* * @@ -318,59 +302,55 @@ Generate the "phantom" info table and update code, iff the constructor returns i genPhantomUpdInfo :: CompilationInfo -> TyCon -> Id{-data con-} -> AbstractC -genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con - = case (dataReturnConvAlg isw_chkr data_con) of +genPhantomUpdInfo comp_info tycon data_con + = case (dataReturnConvAlg data_con) of - ReturnInHeap -> --OLD: pprTrace "NoPhantom: " (ppr PprDebug data_con) $ - AbsCNop -- No need for a phantom update + ReturnInHeap -> AbsCNop -- No need for a phantom update - ReturnInRegs regs -> - --OLD: pprTrace "YesPhantom! " (ppr PprDebug data_con) $ - let - phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing + ReturnInRegs regs -> + let + phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing upd_code con_descr - (dataConLiveness isw_chkr phantom_ci) + (dataConLiveness phantom_ci) + + phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con) - phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con) - - con_descr = _UNPK_ (getOccurrenceName data_con) + con_descr = _UNPK_ (getLocalName data_con) - con_arity = getDataConArity data_con + con_arity = dataConArity data_con - upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return) + upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return) upd_label = mkConUpdCodePtrVecLabel tycon tag - tag = getDataConTag data_con + tag = dataConTag data_con - updatee = CVal (SpBRel 0 (-uF_UPDATEE)) PtrKind + updatee = CVal (SpBRel 0 (- uF_UPDATEE)) PtrRep - perform_return = mkAbstractCs - [ - CMacroStmt POP_STD_UPD_FRAME [], - CReturn (CReg RetReg) return_info - ] + perform_return = mkAbstractCs + [ + CMacroStmt POP_STD_UPD_FRAME [], + CReturn (CReg RetReg) return_info + ] - return_info = - -- OLD: pprTrace "ctrlReturn6:" (ppr PprDebug tycon) ( + return_info = case (ctrlReturnConvAlg tycon) of UnvectoredReturn _ -> DirectReturn - VectoredReturn _ -> StaticVectoredReturn (tag - fIRST_TAG) - -- ) + 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) + do_move (reg, virt_offset) = + CAssign (CVal (NodeRel virt_offset) (magicIdPrimRep 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 - [ + absC (mkAbstractCs + [ CAssign (CReg node) updatee, -- Tell the storage mgr that we intend to update in place @@ -383,12 +363,12 @@ genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con 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 + CAssign (CReg infoptr) (CLbl info_label DataPtrRep) + else AbsCNop ]) - upd_inplace_macro = if closurePtrsSize closure_info == 0 + upd_inplace_macro = if closurePtrsSize closure_info == 0 then UPD_INPLACE_NOPTRS else UPD_INPLACE_PTRS @@ -400,29 +380,29 @@ genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con -- 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 -> + 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 + absC (mkAbstractCs [ CMacroStmt UPD_IND [updatee, amode], CAssign (CReg node) amode, - CAssign (CReg infoptr) (CLbl info_label DataPtrKind) + CAssign (CReg infoptr) (CLbl info_label DataPtrRep) ]) - (closure_info, regs_w_offsets) = layOutDynCon data_con kindFromMagicId regs - info_label = infoTableLabelFromCI closure_info - liveness_mask = mkIntCLit (mkLiveRegsBitMask (node:regs)) + (closure_info, regs_w_offsets) = layOutDynCon data_con magicIdPrimRep regs + info_label = infoTableLabelFromCI closure_info + liveness_mask = mkIntCLit (mkLiveRegsMask (node:regs)) - build_closure = + build_closure = if fitsMinUpdSize closure_info then - initC comp_info overwrite_code + initC comp_info overwrite_code else - initC comp_info (heapCheck regs False alloc_code) + initC comp_info (heapCheck regs False alloc_code) - in CClosureUpdInfo phantom_itbl + in CClosureUpdInfo phantom_itbl \end{code}