X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FCLabel.lhs;h=94b84e5a2c5b793e2e793e9cfb12ecb56b79b4e3;hb=0fe38fdce8e7c7e88fd1188ba95c085717524e21;hp=98464fa3eba2282e467c6a2c5f0b960dddcb85ba;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 98464fa..94b84e5 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -4,8 +4,6 @@ \section[CLabel]{@CLabel@: Information to make C Labels} \begin{code} -#include "HsVersions.h" - module CLabel ( CLabel, -- abstract type @@ -47,30 +45,28 @@ module CLabel ( #endif ) where -IMP_Ubiq(){-uitous-} -IMPORT_DELOOPER(AbsCLoop) ( CtrlReturnConvention(..), - ctrlReturnConvAlg - ) + +#include "HsVersions.h" + #if ! OMIT_NATIVE_CODEGEN -IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl ) +import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl ) #endif +import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg ) import CStrings ( pp_cSEP ) import Id ( externallyVisibleId, cmpId_withSpecDataCon, isDataCon, isDictFunId, - isConstMethodId_maybe, isDefaultMethodId_maybe, isSuperDictSelId_maybe, fIRST_TAG, - SYN_IE(ConTag), GenId{-instance Outputable-} + ConTag, GenId{-instance Outputable-}, + Id ) 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 Util ( assertPanic{-, pprTraceToDo:rm-} ) +import Outputable \end{code} things we want to find out: @@ -112,19 +108,16 @@ 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 (a `cmp` b) of { EQ_ -> True; _ -> False } - CLabelId a /= CLabelId b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + CLabelId a == CLabelId b = case (a `compare` b) of { EQ -> True; _ -> False } + CLabelId a /= CLabelId b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord CLabelId where - 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 } + CLabelId a <= CLabelId b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + CLabelId a < CLabelId b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + CLabelId a >= CLabelId b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + CLabelId a > CLabelId b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare (CLabelId a) (CLabelId b) = a `cmpId_withSpecDataCon` b \end{code} \begin{code} @@ -313,95 +306,104 @@ duplicate declarations in generating C (see @labelSeenTE@ in \begin{code} -- specialised for PprAsm: saves lots of arg passing in NCG #if ! OMIT_NATIVE_CODEGEN -pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl) +pprCLabel_asm = pprCLabel #endif -pprCLabel :: PprStyle -> CLabel -> Unpretty +pprCLabel :: CLabel -> SDoc -pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u) - = uppStr (fmtAsmLbl (_UNPK_ (showUnique u))) +#if ! OMIT_NATIVE_CODEGEN +pprCLabel (AsmTempLabel u) + = text (fmtAsmLbl (showUnique u)) +#endif + +pprCLabel lbl = +#if ! OMIT_NATIVE_CODEGEN + getPprStyle $ \ sty -> + if asmStyle sty && underscorePrefix then + pp_cSEP <> pprCLbl lbl + else +#endif + pprCLbl lbl -pprCLabel (PprForAsm prepend_cSEP _) lbl - = if prepend_cSEP - then uppBeside pp_cSEP prLbl - else prLbl - where - prLbl = pprCLabel PprForC lbl -pprCLabel sty (TyConLabel tc UnvecConUpdCode) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc, - pp_cSEP, uppPStr SLIT("upd")] +pprCLbl (TyConLabel tc UnvecConUpdCode) + = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon tc, + pp_cSEP, ptext SLIT("upd")] -pprCLabel sty (TyConLabel tc (VecConUpdCode tag)) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP, - uppInt tag, pp_cSEP, uppPStr SLIT("upd")] +pprCLbl (TyConLabel tc (VecConUpdCode tag)) + = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon tc, pp_cSEP, + int tag, pp_cSEP, ptext SLIT("upd")] -pprCLabel sty (TyConLabel tc (StdUpdCode tag)) +pprCLbl (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)) + +pprCLbl (TyConLabel tc InfoTblVecTbl) + = hcat [ppr_tycon tc, pp_cSEP, ptext SLIT("itblvtbl")] -pprCLabel sty (TyConLabel tc InfoTblVecTbl) - = uppBesides [ppr_tycon sty tc, pp_cSEP, uppPStr SLIT("itblvtbl")] +pprCLbl (TyConLabel tc StdUpdVecTbl) + = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon tc, + pp_cSEP, ptext SLIT("upd")] -pprCLabel sty (TyConLabel tc StdUpdVecTbl) - = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc, - pp_cSEP, uppPStr SLIT("upd")] +pprCLbl (CaseLabel u CaseReturnPt) + = hcat [ptext SLIT("ret"), pp_cSEP, ppr_u u] +pprCLbl (CaseLabel u CaseVecTbl) + = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_u u] +pprCLbl (CaseLabel u (CaseAlt tag)) + = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int tag] +pprCLbl (CaseLabel u CaseDefault) + = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u] -pprCLabel sty (CaseLabel u CaseReturnPt) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u] -pprCLabel sty (CaseLabel u CaseVecTbl) - = uppBesides [uppPStr 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] -pprCLabel sty (CaseLabel u CaseDefault) - = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u] +pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode") -pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode") +pprCLbl (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info") -pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info") +pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset)) + = hcat [ptext SLIT("__sel_info_"), text (show offset), + ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")), + ptext SLIT("__")] -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("__")] +pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset)) + = hcat [ptext SLIT("__sel_entry_"), 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("__")] +pprCLbl (IdLabel (CLabelId id) flavor) + = ppr id <> ppFlavor flavor -pprCLabel sty (IdLabel (CLabelId id) flavor) - = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor) -ppr_u u = prettyToUn (pprUnique u) +ppr_u u = pprUnique u -ppr_tycon sty tc +ppr_tycon :: TyCon -> SDoc +ppr_tycon tc = ppr tc +{- = let - str = showTyCon sty tc + str = showTyCon tc in - --pprTrace "ppr_tycon:" (ppStr str) $ - uppStr str + --pprTrace "ppr_tycon:" (text str) $ + text str +-} -ppFlavor :: IdLabelInfo -> Unpretty +ppFlavor :: IdLabelInfo -> SDoc -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) - 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") - 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}