diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index fa2cb48..22be603 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -287,10 +287,10 @@ data IdLabelInfo | RednCounts -- ^ Label of place to keep Ticky-ticky info for this Id - | ConEntry -- ^ Constructor entry point - | ConInfoTable -- ^ Corresponding info table - | StaticConEntry -- ^ Static constructor entry point - | StaticInfoTable -- ^ Corresponding info table + | ConEntry -- ^ Constructor entry point + | ConInfoTable -- ^ Corresponding info table + | StaticConEntry Bool -- ^ Static constructor entry point. Flag marks whether is is local. + | StaticInfoTable Bool -- ^ Corresponding info table. Flag marks whether is is local. | ClosureTable -- ^ Table of closures for Enum tycons @@ -366,13 +366,13 @@ mkEntryLabel name c = IdLabel name c Entry mkClosureTableLabel name c = IdLabel name c ClosureTable mkLocalConInfoTableLabel c con = IdLabel con c ConInfoTable mkLocalConEntryLabel c con = IdLabel con c ConEntry -mkLocalStaticInfoTableLabel c con = IdLabel con c StaticInfoTable -mkLocalStaticConEntryLabel c con = IdLabel con c StaticConEntry +mkLocalStaticInfoTableLabel c con = IdLabel con c (StaticInfoTable True) +mkLocalStaticConEntryLabel c con = IdLabel con c (StaticConEntry True) mkConInfoTableLabel name c = IdLabel name c ConInfoTable -mkStaticInfoTableLabel name c = IdLabel name c StaticInfoTable +mkStaticInfoTableLabel name c = IdLabel name c (StaticInfoTable False) mkConEntryLabel name c = IdLabel name c ConEntry -mkStaticConEntryLabel name c = IdLabel name c StaticConEntry +mkStaticConEntryLabel name c = IdLabel name c (StaticConEntry False) -- Constructing Cmm Labels mkSplitMarkerLabel = CmmLabel rtsPackageId (fsLit "__stg_split_marker") CmmCode @@ -498,23 +498,23 @@ mkPlainModuleInitLabel mod = PlainModuleInitLabel mod -- Converting between info labels and entry/ret labels. infoLblToEntryLbl :: CLabel -> CLabel -infoLblToEntryLbl (IdLabel n c InfoTable) = IdLabel n c Entry -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 (IdLabel n c InfoTable) = IdLabel n c Entry +infoLblToEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry +infoLblToEntryLbl (IdLabel n c (StaticInfoTable l)) = IdLabel n c (StaticConEntry l) +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) = IdLabel n c InfoTable -entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable -entryLblToInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable -entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo -entryLblToInfoLbl (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo -entryLblToInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo +entryLblToInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable +entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable +entryLblToInfoLbl (IdLabel n c (StaticConEntry l)) = IdLabel n c (StaticInfoTable l) +entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo +entryLblToInfoLbl (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo +entryLblToInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l) @@ -700,8 +700,9 @@ externallyVisibleCLabel (LargeBitmapLabel _) = False externallyVisibleCLabel (LargeSRTLabel _) = False externallyVisibleIdLabel :: IdLabelInfo -> Bool -externallyVisibleIdLabel SRT = False -externallyVisibleIdLabel _ = True +externallyVisibleIdLabel SRT = False +externallyVisibleIdLabel (StaticInfoTable local) = not local +externallyVisibleIdLabel _ = True -- ----------------------------------------------------------------------------- -- Finding the "type" of a CLabel @@ -748,13 +749,13 @@ labelType _ = DataLabel idInfoLabelType info = case info of - InfoTable -> DataLabel - Closure -> GcPtrLabel - ConInfoTable -> DataLabel - StaticInfoTable -> DataLabel - ClosureTable -> DataLabel - RednCounts -> DataLabel - _ -> CodeLabel + InfoTable -> DataLabel + Closure -> GcPtrLabel + ConInfoTable -> DataLabel + StaticInfoTable _ -> DataLabel + ClosureTable -> DataLabel + RednCounts -> DataLabel + _ -> CodeLabel -- ----------------------------------------------------------------------------- @@ -982,17 +983,17 @@ pprCLbl (HpcTicksLabel mod) ppIdFlavor :: IdLabelInfo -> SDoc ppIdFlavor x = pp_cSEP <> (case x of - Closure -> ptext (sLit "closure") - SRT -> ptext (sLit "srt") - InfoTable -> ptext (sLit "info") - Entry -> ptext (sLit "entry") - Slow -> ptext (sLit "slow") - RednCounts -> ptext (sLit "ct") - ConEntry -> ptext (sLit "con_entry") - ConInfoTable -> ptext (sLit "con_info") - StaticConEntry -> ptext (sLit "static_entry") - StaticInfoTable -> ptext (sLit "static_info") - ClosureTable -> ptext (sLit "closure_tbl") + Closure -> ptext (sLit "closure") + SRT -> ptext (sLit "srt") + InfoTable -> ptext (sLit "info") + Entry -> ptext (sLit "entry") + Slow -> ptext (sLit "slow") + RednCounts -> ptext (sLit "ct") + ConEntry -> ptext (sLit "con_entry") + ConInfoTable -> ptext (sLit "con_info") + StaticConEntry _ -> ptext (sLit "static_entry") + StaticInfoTable _ -> ptext (sLit "static_info") + ClosureTable -> ptext (sLit "closure_tbl") ) diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 8768008..10b66e2 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -71,32 +71,50 @@ cgTopRhsCon id con args ; ASSERT( not (isDllConApp this_pkg con args) ) return () #endif ; ASSERT( args `lengthIs` dataConRepArity con ) return () - - -- LAY IT OUT - ; amodes <- getArgAmodes args - - ; let - name = idName id - lf_info = mkConLFInfo con - closure_label = mkClosureLabel name $ idCafInfo id - caffy = any stgArgHasCafRefs args - (closure_info, amodes_w_offsets) = layOutStaticConstr con amodes - closure_rep = mkStaticClosureFields - closure_info - dontCareCCS -- Because it's static data - caffy -- Has CAF refs - payload - - payload = map get_lit amodes_w_offsets - get_lit (CmmLit lit, _offset) = lit - get_lit other = pprPanic "CgCon.get_lit" (ppr other) - -- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs - -- NB2: all the amodes should be Lits! - - -- BUILD THE OBJECT + + -- LAY IT OUT + -- We have to special case nullary data constructors because (to cut down on symbol bloat) + -- we avoid exporting their _static_info pointer. Ideally, we would just generate a linker + -- directive that aliases the id_closure we are generating right here to that earlier one. + -- Unfortunately, this is hard to do in a portable fashion, so instead we generate a statically-allocated + -- indirection to the original closure. The GC should short out indirections to make this + -- reasonably efficient. + -- + -- TODO: could use a putatitive stg_IND_STATIC_direct + ; closure_rep <- case isNullaryRepDataCon con of + True -> return $ mkStaticClosure + mkIndStaticInfoLabel -- Info pointer = that of static indirection + dontCareCCS -- Because it's static data + [CmmLabelOff (mkClosureLabel (dataConName con) (idCafInfo id)) (tagForCon con)] -- Payload: must be pointer-tagged + [] -- Closure not a CAF ==> no padding + [mkIntCLit 1] -- Mark as having no CAF references (see also mkStaticClosureFields) + [] -- Closure not a CAF ==> no saved info + False -> + do { amodes <- getArgAmodes args + ; let + caffy = any stgArgHasCafRefs args + (closure_info, amodes_w_offsets) = layOutStaticConstr con amodes + closure_rep = mkStaticClosureFields + closure_info + dontCareCCS -- Because it's static data + caffy -- Has CAF refs + payload + + payload = map get_lit amodes_w_offsets + get_lit (CmmLit lit, _offset) = lit + get_lit other = pprPanic "CgCon.get_lit" (ppr other) + -- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs + -- NB2: all the amodes should be Lits! + + ; return closure_rep } + + -- BUILD THE OBJECT + ; let name = idName id + closure_label = mkClosureLabel name $ idCafInfo id ; emitDataLits closure_label closure_rep - -- RETURN + -- RETURN + ; let lf_info = mkConLFInfo con ; returnFC (id, taggedStableIdInfo id (mkLblExpr closure_label) lf_info con) } \end{code} diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index 4f59d95..8057189 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -935,7 +935,11 @@ infoTableLabelFromCI (ClosureInfo { closureName = name, infoTableLabelFromCI (ConInfo { closureCon = con, closureSMRep = rep }) caf - | isStaticRep rep = mkStaticInfoTableLabel name caf + -- Don't need to export _static_info for nullary constructors, + -- because other modules will just use the _closure directly + | isStaticRep rep = if isNullaryRepDataCon con + then mkLocalStaticInfoTableLabel caf name + else mkStaticInfoTableLabel name caf | otherwise = mkConInfoTableLabel name caf where name = dataConName con diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index a8d91f5..d1589d6 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -1004,7 +1004,11 @@ infoTableLabelFromCI cl@(ClosureInfo { closureName = name, _other -> panic "infoTableLabelFromCI" infoTableLabelFromCI cl@(ConInfo { closureCon = con, closureSMRep = rep }) - | isStaticRep rep = mkStaticInfoTableLabel name $ clHasCafRefs cl + -- Don't need to export _static_info for nullary constructors, + -- because other modules will just use the _closure directly + | isStaticRep rep = if isNullaryRepDataCon con + then mkLocalStaticInfoTableLabel (clHasCafRefs cl) name + else mkStaticInfoTableLabel name (clHasCafRefs cl) | otherwise = mkConInfoTableLabel name $ clHasCafRefs cl where name = dataConName con diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 368bc53..5f2c3a2 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -25,6 +25,7 @@ import StgCmmUtils import StgCmmClosure import StgCmmProf +import CmmUtils ( mkIntCLit ) import CmmExpr import CLabel import MkGraph @@ -65,31 +66,48 @@ cgTopRhsCon id con args ; ASSERT( args `lengthIs` dataConRepArity con ) return () -- LAY IT OUT - ; let - name = idName id - lf_info = mkConLFInfo con - closure_label = mkClosureLabel name $ idCafInfo id - caffy = any stgArgHasCafRefs args - (closure_info, nv_args_w_offsets) - = layOutStaticConstr con (addArgReps args) - - get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg - ; return lit } - - ; payload <- mapM get_lit nv_args_w_offsets - -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs - -- NB2: all the amodes should be Lits! - - ; let closure_rep = mkStaticClosureFields - closure_info - dontCareCCS -- Because it's static data - caffy -- Has CAF refs - payload + -- We have to special case nullary data constructors because (to cut down on symbol bloat) + -- we avoid exporting their _static_info pointer. Ideally, we would just generate a linker + -- directive that aliases the id_closure we are generating right here to that earlier one. + -- Unfortunately, this is hard to do in a portable fashion, so instead we generate a statically-allocated + -- indirection to the original closure. The GC should short out indirections to make this + -- reasonably efficient. + -- + -- TODO: could use a putatitive stg_IND_STATIC_direct + ; closure_rep <- case isNullaryRepDataCon con of + True -> return $ mkStaticClosure + mkIndStaticInfoLabel -- Info pointer = that of static indirection + dontCareCCS -- Because it's static data + [CmmLabelOff (mkClosureLabel (dataConName con) (idCafInfo id)) (tagForCon con)] -- Payload: must be pointer-tagged + [] -- Closure not a CAF ==> no padding + [mkIntCLit 1] -- Mark as having no CAF references (see also mkStaticClosureFields) + [] -- Closure not a CAF ==> no saved info + False -> + do { let + caffy = any stgArgHasCafRefs args + (closure_info, nv_args_w_offsets) + = layOutStaticConstr con (addArgReps args) + + get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg + ; return lit } + + ; payload <- mapM get_lit nv_args_w_offsets + -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs + -- NB2: all the amodes should be Lits! + + ; return $ mkStaticClosureFields + closure_info + dontCareCCS -- Because it's static data + caffy -- Has CAF refs + payload } -- BUILD THE OBJECT + ; let name = idName id + closure_label = mkClosureLabel name $ idCafInfo id ; emitDataLits closure_label closure_rep -- RETURN + ; let lf_info = mkConLFInfo con ; return $ litIdInfo id lf_info (CmmLabel closure_label) }