X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FCLabel.lhs;h=1ecd2e10365c7538f1bba08712da5c130e0391fb;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=2ecbd17348025e9cc23a2aa0151be5b6a1a913cc;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 2ecbd17..1ecd2e1 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -16,7 +16,9 @@ module CLabel ( mkConEntryLabel, mkStaticConEntryLabel, mkRednCountsLabel, + mkConInfoTableLabel, mkPhantomInfoTableLabel, + mkStaticClosureLabel, mkStaticInfoTableLabel, mkVapEntryLabel, mkVapInfoTableLabel, @@ -40,39 +42,35 @@ module CLabel ( needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel, pprCLabel - -#ifdef GRAN - , isSlowEntryCCodeBlock +#if ! OMIT_NATIVE_CODEGEN + , pprCLabel_asm #endif - - -- and to make the interface self-sufficient... ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(AbsCLoop) ( CtrlReturnConvention(..), + ctrlReturnConvAlg + ) +#if ! OMIT_NATIVE_CODEGEN +IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl ) +#endif +import CStrings ( pp_cSEP ) import Id ( externallyVisibleId, cmpId_withSpecDataCon, isDataCon, isDictFunId, - isConstMethodId_maybe, isClassOpId, + isConstMethodId_maybe, isDefaultMethodId_maybe, isSuperDictSelId_maybe, fIRST_TAG, - DataCon(..), ConTag(..), Id + SYN_IE(ConTag), GenId{-instance Outputable-} ) import Maybes ( maybeToBool ) +import PprStyle ( PprStyle(..) ) +import PprType ( showTyCon, GenType{-instance Outputable-} ) +import Pretty ( prettyToUn{-, ppPStr ToDo:rm-} ) +import TyCon ( TyCon{-instance Eq-} ) +import Unique ( showUnique, pprUnique, Unique{-instance Eq-} ) import Unpretty -- NOTE!! ******************** -{- -import Outputable -import Pretty ( ppNil, ppChar, ppStr, ppPStr, ppDouble, ppInt, - ppInteger, ppBeside, ppIntersperse, prettyToUn - ) -#ifdef USE_ATTACK_PRAGMAS -import CharSeq -#endif -import Unique ( pprUnique, showUnique, Unique ) -import Util - --- Sigh... Shouldn't this file (CLabel) live in codeGen? -import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg ) --} +import Util ( assertPanic{-, pprTraceToDo:rm-} ) \end{code} things we want to find out: @@ -114,26 +112,25 @@ unspecialised constructors are compared. \begin{code} data CLabelId = CLabelId Id +instance Ord3 CLabelId where + cmp (CLabelId a) (CLabelId b) = cmpId_withSpecDataCon a b + instance Eq CLabelId where - CLabelId a == CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> True; _ -> False } - CLabelId a /= CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> False; _ -> True } + CLabelId a == CLabelId b = case (a `cmp` b) of { EQ_ -> True; _ -> False } + CLabelId a /= CLabelId b = case (a `cmp` b) of { EQ_ -> False; _ -> True } instance Ord CLabelId where - CLabelId a <= CLabelId b = case cmpId_withSpecDataCon a b - of { LT_ -> True; EQ_ -> True; GT__ -> False } - CLabelId a < CLabelId b = case cmpId_withSpecDataCon a b - of { LT_ -> True; EQ_ -> False; GT__ -> False } - CLabelId a >= CLabelId b = case cmpId_withSpecDataCon a b - of { LT_ -> False; EQ_ -> True; GT__ -> True } - CLabelId a > CLabelId b = case cmpId_withSpecDataCon a b - of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp (CLabelId a) (CLabelId b) = case cmpId_withSpecDataCon a b - of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } + CLabelId a <= CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } + CLabelId a < CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } + CLabelId a >= CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } + CLabelId a > CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } + _tagCmp (CLabelId a) (CLabelId b) = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } \end{code} \begin{code} data IdLabelInfo = Closure -- Label for (static???) closure + | StaticClosure -- Static closure -- e.g., nullary constructor | InfoTbl -- Info table for a closure; always read-only @@ -143,14 +140,15 @@ data IdLabelInfo -- encoded into the name) | ConEntry -- the only kind of entry pt for constructors - | StaticConEntry -- static constructor entry point + | ConInfoTbl -- corresponding info table + | StaticConEntry -- static constructor entry point | StaticInfoTbl -- corresponding info table | PhantomInfoTbl -- for phantom constructors that only exist in regs | VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version - | VapEntry Bool + | VapEntry Bool -- Ticky-ticky counting | RednCounts -- Label of place to keep reduction-count info for this Id @@ -199,18 +197,28 @@ data RtsLabelInfo \end{code} \begin{code} -mkClosureLabel id = IdLabel (CLabelId id) Closure -mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl -mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd +mkClosureLabel id = IdLabel (CLabelId id) Closure +mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl +mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd mkFastEntryLabel id arity = ASSERT(arity > 0) - IdLabel (CLabelId id) (EntryFast arity) -mkConEntryLabel id = IdLabel (CLabelId id) ConEntry -mkStaticConEntryLabel id = IdLabel (CLabelId id) StaticConEntry -mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts -mkPhantomInfoTableLabel id = IdLabel (CLabelId id) PhantomInfoTbl -mkStaticInfoTableLabel id = IdLabel (CLabelId id) StaticInfoTbl -mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag) -mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag) + IdLabel (CLabelId id) (EntryFast arity) + +mkStaticClosureLabel con = ASSERT(isDataCon con) + IdLabel (CLabelId con) StaticClosure +mkStaticInfoTableLabel con = ASSERT(isDataCon con) + IdLabel (CLabelId con) StaticInfoTbl +mkConInfoTableLabel con = ASSERT(isDataCon con) + IdLabel (CLabelId con) ConInfoTbl +mkPhantomInfoTableLabel con = ASSERT(isDataCon con) + IdLabel (CLabelId con) PhantomInfoTbl +mkConEntryLabel con = ASSERT(isDataCon con) + IdLabel (CLabelId con) ConEntry +mkStaticConEntryLabel con = ASSERT(isDataCon con) + IdLabel (CLabelId con) StaticConEntry + +mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts +mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag) +mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag) mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag) mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag) @@ -262,11 +270,12 @@ needsCDecl other = True Whether the labelled thing can be put in C "text space": \begin{code} -isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes -isReadOnly (IdLabel _ StaticInfoTbl) = True -- and so on, for other -isReadOnly (IdLabel _ PhantomInfoTbl) = True -isReadOnly (IdLabel _ (VapInfoTbl _)) = True -isReadOnly (IdLabel _ other) = False -- others: pessimistically, no +isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes +isReadOnly (IdLabel _ ConInfoTbl) = True -- and so on, for other +isReadOnly (IdLabel _ StaticInfoTbl) = True +isReadOnly (IdLabel _ PhantomInfoTbl) = True +isReadOnly (IdLabel _ (VapInfoTbl _)) = True +isReadOnly (IdLabel _ other) = False -- others: pessimistically, no isReadOnly (TyConLabel _ _) = True isReadOnly (CaseLabel _ _) = True @@ -290,53 +299,47 @@ externallyVisibleCLabel (IdLabel (CLabelId id) _) | isDataCon id = True | is_ConstMethodId id = True -- These are here to ensure splitting works | isDictFunId id = True -- when these values have not been exported - | isClassOpId id = True | is_DefaultMethodId id = True | is_SuperDictSelId id = True | otherwise = externallyVisibleId id where - is_ConstMethodId id = maybeToBool (isConstMethodId_maybe id) + is_ConstMethodId id = maybeToBool (isConstMethodId_maybe id) is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id) - is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id) + is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id) \end{code} -These GRAN functions are needed for spitting out GRAN_FETCH() at the +OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the right places. It is used to detect when the abstractC statement of an CCodeBlock actually contains the code for a slow entry point. -- HWL -\begin{code} -#ifdef GRAN - -isSlowEntryCCodeBlock :: CLabel -> Bool -isSlowEntryCCodeBlock _ = False --- Worth keeping? ToDo (WDP) - -#endif {-GRAN-} -\end{code} - We need at least @Eq@ for @CLabels@, because we want to avoid duplicate declarations in generating C (see @labelSeenTE@ in @PprAbsC@). \begin{code} +-- specialised for PprAsm: saves lots of arg passing in NCG +#if ! OMIT_NATIVE_CODEGEN +pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl) +#endif + pprCLabel :: PprStyle -> CLabel -> Unpretty -pprCLabel (PprForAsm _ _ fmtAsmLbl) (AsmTempLabel u) +pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u) = uppStr (fmtAsmLbl (_UNPK_ (showUnique u))) -pprCLabel (PprForAsm sw_chker prepend_cSEP _) lbl +pprCLabel (PprForAsm prepend_cSEP _) lbl = if prepend_cSEP then uppBeside pp_cSEP prLbl else prLbl where - prLbl = pprCLabel (PprForC sw_chker) lbl + prLbl = pprCLabel PprForC lbl pprCLabel sty (TyConLabel tc UnvecConUpdCode) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), + = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP, uppPStr SLIT("upd")] pprCLabel sty (TyConLabel tc (VecConUpdCode tag)) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), pp_cSEP, + = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP, uppInt tag, pp_cSEP, uppPStr SLIT("upd")] pprCLabel sty (TyConLabel tc (StdUpdCode tag)) @@ -345,10 +348,10 @@ pprCLabel sty (TyConLabel tc (StdUpdCode tag)) VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG)) pprCLabel sty (TyConLabel tc InfoTblVecTbl) - = uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")] + = uppBesides [ppr_tycon sty tc, pp_cSEP, uppPStr SLIT("itblvtbl")] pprCLabel sty (TyConLabel tc StdUpdVecTbl) - = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc), + = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc, pp_cSEP, uppPStr SLIT("upd")] pprCLabel sty (CaseLabel u CaseReturnPt) @@ -379,6 +382,13 @@ pprCLabel sty (IdLabel (CLabelId id) flavor) ppr_u u = prettyToUn (pprUnique u) +ppr_tycon sty tc + = let + str = showTyCon sty tc + in + --pprTrace "ppr_tycon:" (ppStr str) $ + uppStr str + ppFlavor :: IdLabelInfo -> Unpretty ppFlavor x = uppBeside pp_cSEP @@ -388,7 +398,9 @@ ppFlavor x = uppBeside pp_cSEP EntryStd -> uppPStr SLIT("entry") EntryFast arity -> --false:ASSERT (arity > 0) uppBeside (uppPStr SLIT("fast")) (uppInt arity) - ConEntry -> uppPStr SLIT("entry") + StaticClosure -> uppPStr SLIT("static_closure") + ConEntry -> uppPStr SLIT("con_entry") + ConInfoTbl -> uppPStr SLIT("con_info") StaticConEntry -> uppPStr SLIT("static_entry") StaticInfoTbl -> uppPStr SLIT("static_info") PhantomInfoTbl -> uppPStr SLIT("inregs_info") @@ -399,4 +411,3 @@ ppFlavor x = uppBeside pp_cSEP RednCounts -> uppPStr SLIT("ct") ) \end{code} -