X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FCLabel.lhs;h=9fedf648a141131f85457cdd5a2ced9790cfe360;hb=63181f98a25fd8883c88ac7c89a471a02bb3f196;hp=f35342ca4b6cc9bbd50fd0d6979fd99c5bd85342;hpb=dabfa71f33eabc5a2d10959728f772aa016f1c84;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index f35342c..9fedf64 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, @@ -45,12 +47,22 @@ module CLabel ( #endif ) where -import Ubiq{-uitous-} -import AbsCLoop ( CtrlReturnConvention(..), +IMP_Ubiq(){-uitous-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 +IMPORT_DELOOPER(AbsCLoop) ( CtrlReturnConvention(..), ctrlReturnConvAlg ) +#else +import {-# SOURCE #-} CgRetConv +#endif + + #if ! OMIT_NATIVE_CODEGEN -import NcgLoop ( underscorePrefix, fmtAsmLbl ) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 +IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl ) +#else +import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl ) +#endif #endif import CStrings ( pp_cSEP ) @@ -59,16 +71,16 @@ import Id ( externallyVisibleId, cmpId_withSpecDataCon, isConstMethodId_maybe, isDefaultMethodId_maybe, isSuperDictSelId_maybe, fIRST_TAG, - ConTag(..), GenId{-instance Outputable-} + SYN_IE(ConTag), GenId{-instance Outputable-}, + SYN_IE(Id) ) import Maybes ( maybeToBool ) -import PprStyle ( PprStyle(..) ) +import Outputable ( Outputable(..), PprStyle(..) ) import PprType ( showTyCon, GenType{-instance Outputable-} ) -import Pretty ( prettyToUn ) import TyCon ( TyCon{-instance Eq-} ) import Unique ( showUnique, pprUnique, Unique{-instance Eq-} ) -import Unpretty -- NOTE!! ******************** -import Util ( assertPanic ) +import Pretty +import Util ( assertPanic{-, pprTraceToDo:rm-}, Ord3(..) ) \end{code} things we want to find out: @@ -110,26 +122,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 @@ -139,14 +150,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 @@ -195,18 +207,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) @@ -258,11 +280,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 @@ -277,22 +300,16 @@ isAsmTemp _ = False \end{code} C ``static'' or not... +From the point of view of the code generator, a name is +externally visible if it should be given put in the .o file's +symbol table; that is, made static. + \begin{code} externallyVisibleCLabel (TyConLabel tc _) = True externallyVisibleCLabel (CaseLabel _ _) = False externallyVisibleCLabel (AsmTempLabel _) = False externallyVisibleCLabel (RtsLabel _) = True -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 - | is_DefaultMethodId id = True - | is_SuperDictSelId id = True - | otherwise = externallyVisibleId id - where - is_ConstMethodId id = maybeToBool (isConstMethodId_maybe id) - is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id) - is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id) +externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id \end{code} OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the @@ -309,83 +326,92 @@ duplicate declarations in generating C (see @labelSeenTE@ in pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl) #endif -pprCLabel :: PprStyle -> CLabel -> Unpretty +pprCLabel :: PprStyle -> CLabel -> Doc pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u) - = uppStr (fmtAsmLbl (_UNPK_ (showUnique u))) + = text (fmtAsmLbl (_UNPK_ (showUnique u))) pprCLabel (PprForAsm prepend_cSEP _) lbl = if prepend_cSEP - then uppBeside pp_cSEP prLbl + then (<>) pp_cSEP prLbl else prLbl where prLbl = pprCLabel PprForC lbl pprCLabel sty (TyConLabel tc UnvecConUpdCode) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), - pp_cSEP, uppPStr SLIT("upd")] + = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc, + pp_cSEP, ptext SLIT("upd")] pprCLabel sty (TyConLabel tc (VecConUpdCode tag)) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), pp_cSEP, - uppInt tag, pp_cSEP, uppPStr SLIT("upd")] + = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP, + int tag, pp_cSEP, ptext SLIT("upd")] pprCLabel sty (TyConLabel tc (StdUpdCode tag)) = case (ctrlReturnConvAlg tc) of - UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir") - VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG)) + UnvectoredReturn _ -> ptext SLIT("IndUpdRetDir") + VectoredReturn _ -> (<>) (ptext SLIT("IndUpdRetV")) (int (tag - fIRST_TAG)) pprCLabel sty (TyConLabel tc InfoTblVecTbl) - = uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")] + = hcat [ppr_tycon sty tc, pp_cSEP, ptext SLIT("itblvtbl")] pprCLabel sty (TyConLabel tc StdUpdVecTbl) - = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc), - pp_cSEP, uppPStr SLIT("upd")] + = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc, + pp_cSEP, ptext SLIT("upd")] pprCLabel sty (CaseLabel u CaseReturnPt) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u] + = hcat [ptext SLIT("ret"), pp_cSEP, ppr_u u] pprCLabel sty (CaseLabel u CaseVecTbl) - = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u] + = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_u u] pprCLabel sty (CaseLabel u (CaseAlt tag)) - = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, uppInt tag] + = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int tag] pprCLabel sty (CaseLabel u CaseDefault) - = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u] + = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u] -pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode") +pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode") -pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info") +pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info") pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset)) - = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset), - uppStr (if upd_reqd then "upd" else "noupd"), - uppPStr SLIT("__")] + = hcat [ptext SLIT("__sel_info_"), text (show offset), + ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")), + ptext SLIT("__")] pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset)) - = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset), - uppStr (if upd_reqd then "upd" else "noupd"), - uppPStr SLIT("__")] + = hcat [ptext SLIT("__sel_entry_"), text (show offset), + ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")), + ptext SLIT("__")] pprCLabel sty (IdLabel (CLabelId id) flavor) - = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor) + = (<>) (ppr sty id) (ppFlavor flavor) + +ppr_u u = pprUnique u -ppr_u u = prettyToUn (pprUnique u) +ppr_tycon sty tc + = let + str = showTyCon sty tc + in + --pprTrace "ppr_tycon:" (text str) $ + text str -ppFlavor :: IdLabelInfo -> Unpretty +ppFlavor :: IdLabelInfo -> Doc -ppFlavor x = uppBeside pp_cSEP +ppFlavor x = (<>) pp_cSEP (case x of - Closure -> uppPStr SLIT("closure") - InfoTbl -> uppPStr SLIT("info") - EntryStd -> uppPStr SLIT("entry") + Closure -> ptext SLIT("closure") + InfoTbl -> ptext SLIT("info") + EntryStd -> ptext SLIT("entry") EntryFast arity -> --false:ASSERT (arity > 0) - uppBeside (uppPStr SLIT("fast")) (uppInt arity) - ConEntry -> uppPStr SLIT("entry") - StaticConEntry -> uppPStr SLIT("static_entry") - StaticInfoTbl -> uppPStr SLIT("static_info") - PhantomInfoTbl -> uppPStr SLIT("inregs_info") - VapInfoTbl True -> uppPStr SLIT("vap_info") - VapInfoTbl False -> uppPStr SLIT("vap_noupd_info") - VapEntry True -> uppPStr SLIT("vap_entry") - VapEntry False -> uppPStr SLIT("vap_noupd_entry") - RednCounts -> uppPStr SLIT("ct") + (<>) (ptext SLIT("fast")) (int arity) + StaticClosure -> ptext SLIT("static_closure") + ConEntry -> ptext SLIT("con_entry") + ConInfoTbl -> ptext SLIT("con_info") + StaticConEntry -> ptext SLIT("static_entry") + StaticInfoTbl -> ptext SLIT("static_info") + PhantomInfoTbl -> ptext SLIT("inregs_info") + VapInfoTbl True -> ptext SLIT("vap_info") + VapInfoTbl False -> ptext SLIT("vap_noupd_info") + VapEntry True -> ptext SLIT("vap_entry") + VapEntry False -> ptext SLIT("vap_noupd_entry") + RednCounts -> ptext SLIT("ct") ) \end{code}