diff options
| -rw-r--r-- | compiler/cmm/CLabel.hs | 15 | ||||
| -rw-r--r-- | compiler/codeGen/ClosureInfo.lhs | 38 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmClosure.hs | 38 |
3 files changed, 49 insertions, 42 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 8828adb0d0..5cafdf468d 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -65,6 +65,7 @@ module CLabel ( mkTopTickyCtrLabel, mkCAFBlackHoleInfoTableLabel, + mkCAFBlackHoleEntryLabel, mkRtsPrimOpLabel, mkRtsSlowTickyCtrLabel, @@ -99,7 +100,7 @@ module CLabel ( mkHpcTicksLabel, hasCAF, - infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, + entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, localiseLabel, needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, isMathFun, @@ -390,6 +391,7 @@ mkMAP_DIRTY_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_DIRTY") mkEMPTY_MVAR_infoLabel = CmmLabel rtsPackageId (fsLit "stg_EMPTY_MVAR") CmmInfo mkTopTickyCtrLabel = CmmLabel rtsPackageId (fsLit "top_ct") CmmData mkCAFBlackHoleInfoTableLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmInfo +mkCAFBlackHoleEntryLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmEntry ----- mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, @@ -501,17 +503,6 @@ mkPlainModuleInitLabel mod = PlainModuleInitLabel mod -- ----------------------------------------------------------------------------- -- Converting between info labels and entry/ret labels. -infoLblToEntryLbl :: CLabel -> CLabel -infoLblToEntryLbl (IdLabel n c (InfoTable lcl)) = IdLabel n c (Entry lcl) -infoLblToEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry -infoLblToEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry -infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt -infoLblToEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry -infoLblToEntryLbl (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet -infoLblToEntryLbl _ - = panic "CLabel.infoLblToEntryLbl" - - entryLblToInfoLbl :: CLabel -> CLabel entryLblToInfoLbl (IdLabel n c (Entry lcl)) = IdLabel n c (InfoTable lcl) entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index e55c4d7585..5db8b125f7 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -80,6 +80,8 @@ import FastString import Outputable import Constants import DynFlags + +import Control.Arrow ((***)) \end{code} @@ -925,33 +927,39 @@ Label generation. \begin{code} infoTableLabelFromCI :: ClosureInfo -> CLabel -infoTableLabelFromCI cl@(ClosureInfo { closureName = name, - closureLFInfo = lf_info, - closureInfLcl = is_lcl }) - = (if is_lcl then localiseLabel else id) $ case lf_info of - LFBlackHole -> mkCAFBlackHoleInfoTableLabel +infoTableLabelFromCI = fst . labelsFromCI + +entryLabelFromCI :: ClosureInfo -> CLabel +entryLabelFromCI = snd . labelsFromCI + +labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry) +labelsFromCI cl@(ClosureInfo { closureName = name, + closureLFInfo = lf_info, + closureInfLcl = is_lcl }) + = (if is_lcl then (localiseLabel *** localiseLabel) else id) $ case lf_info of + LFBlackHole -> (mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel) LFThunk _ _ upd_flag (SelectorThunk offset) _ -> - mkSelectorInfoLabel upd_flag offset + bothL (mkSelectorInfoLabel, mkSelectorEntryLabel) upd_flag offset LFThunk _ _ upd_flag (ApThunk arity) _ -> - mkApInfoTableLabel upd_flag arity + bothL (mkApInfoTableLabel, mkApEntryLabel) upd_flag arity - LFThunk{} -> mkInfoTableLabel name $ clHasCafRefs cl + LFThunk{} -> bothL (mkInfoTableLabel, mkEntryLabel) name $ clHasCafRefs cl - LFReEntrant _ _ _ _ -> mkInfoTableLabel name $ clHasCafRefs cl + LFReEntrant _ _ _ _ -> bothL (mkInfoTableLabel, mkEntryLabel) name $ clHasCafRefs cl - _ -> panic "infoTableLabelFromCI" + _ -> panic "labelsFromCI" -infoTableLabelFromCI cl@(ConInfo { closureCon = con, +labelsFromCI cl@(ConInfo { closureCon = con, closureSMRep = rep }) - | isStaticRep rep = mkStaticInfoTableLabel name $ clHasCafRefs cl - | otherwise = mkConInfoTableLabel name $ clHasCafRefs cl + | isStaticRep rep = bothL (mkStaticInfoTableLabel, mkStaticConEntryLabel) name $ clHasCafRefs cl + | otherwise = bothL (mkConInfoTableLabel, mkConEntryLabel) name $ clHasCafRefs cl where name = dataConName con -entryLabelFromCI :: ClosureInfo -> CLabel -entryLabelFromCI = infoLblToEntryLbl . infoTableLabelFromCI +bothL :: (a -> b -> c, a -> b -> c) -> a -> b -> (c, c) +bothL (f, g) x y = (f x y, g x y) -- ClosureInfo for a closure (as opposed to a constructor) is always local closureLabelFromCI :: ClosureInfo -> CLabel diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index c808f990af..cbcdaab058 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -90,6 +90,8 @@ import Outputable import Constants import DynFlags +import Control.Arrow ((***)) + ----------------------------------------------------------------------------- -- Representations ----------------------------------------------------------------------------- @@ -992,32 +994,38 @@ isToplevClosure _ = False -------------------------------------- infoTableLabelFromCI :: ClosureInfo -> CLabel -infoTableLabelFromCI cl@(ClosureInfo { closureName = name, - closureLFInfo = lf_info, - closureInfLcl = is_lcl }) - = (if is_lcl then localiseLabel else id) $ case lf_info of - LFBlackHole -> mkCAFBlackHoleInfoTableLabel +infoTableLabelFromCI = fst . labelsFromCI + +entryLabelFromCI :: ClosureInfo -> CLabel +entryLabelFromCI = snd . labelsFromCI + +labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry) +labelsFromCI cl@(ClosureInfo { closureName = name, + closureLFInfo = lf_info, + closureInfLcl = is_lcl }) + = (if is_lcl then (localiseLabel *** localiseLabel) else id) $ case lf_info of + LFBlackHole -> (mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel) LFThunk _ _ upd_flag (SelectorThunk offset) _ -> - mkSelectorInfoLabel upd_flag offset + bothL (mkSelectorInfoLabel, mkSelectorEntryLabel) upd_flag offset LFThunk _ _ upd_flag (ApThunk arity) _ -> - mkApInfoTableLabel upd_flag arity + bothL (mkApInfoTableLabel, mkApEntryLabel) upd_flag arity - LFThunk{} -> mkInfoTableLabel name $ clHasCafRefs cl + LFThunk{} -> bothL (mkInfoTableLabel, mkEntryLabel) name $ clHasCafRefs cl - LFReEntrant _ _ _ _ -> mkInfoTableLabel name $ clHasCafRefs cl + LFReEntrant _ _ _ _ -> bothL (mkInfoTableLabel, mkEntryLabel) name $ clHasCafRefs cl - _other -> panic "infoTableLabelFromCI" + _other -> panic "labelsFromCI" -infoTableLabelFromCI cl@(ConInfo { closureCon = con, closureSMRep = rep }) - | isStaticRep rep = mkStaticInfoTableLabel name $ clHasCafRefs cl - | otherwise = mkConInfoTableLabel name $ clHasCafRefs cl +labelsFromCI cl@(ConInfo { closureCon = con, closureSMRep = rep }) + | isStaticRep rep = bothL (mkStaticInfoTableLabel, mkStaticConEntryLabel) name $ clHasCafRefs cl + | otherwise = bothL (mkConInfoTableLabel, mkConEntryLabel) name $ clHasCafRefs cl where name = dataConName con -entryLabelFromCI :: ClosureInfo -> CLabel -entryLabelFromCI = infoLblToEntryLbl . infoTableLabelFromCI +bothL :: (a -> b -> c, a -> b -> c) -> a -> b -> (c, c) +bothL (f, g) x y = (f x y, g x y) -- ClosureInfo for a closure (as opposed to a constructor) is always local closureLabelFromCI :: ClosureInfo -> CLabel |