[Git][ghc/ghc][wip/buggymcbugfix/arrayOf-primop] 2 commits: Comments / refactor
Vilem-Benjamin Liepelt
gitlab at gitlab.haskell.org
Mon Jun 22 20:48:18 UTC 2020
Vilem-Benjamin Liepelt pushed to branch wip/buggymcbugfix/arrayOf-primop at Glasgow Haskell Compiler / GHC
Commits:
7c32daad by buggymcbugfix at 2020-06-22T21:29:44+01:00
Comments / refactor
- - - - -
a810d206 by buggymcbugfix at 2020-06-22T21:45:14+01:00
Implement general arrayOf# primop
- - - - -
11 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Cmm.hs
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/Info/Build.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/HsToCore.hs
- compiler/GHC/Stg/Pipeline.hs
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/StgToCmm/Heap.hs
- compiler/GHC/StgToCmm/Prim.hs
- includes/rts/storage/Closures.h
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -1249,7 +1249,7 @@ primop NewSmallArrayOp "newSmallArray#" GenPrimOp
primop SmallArrayOfOp "smallArrayOf#" GenPrimOp
o -> SmallArray# b
- {Create a new immutable array with two elements.}
+ {smallArrayOf# :: (# a, .., a #) -> Array# a}
with
has_side_effects = True
=====================================
compiler/GHC/Cmm.hs
=====================================
@@ -97,6 +97,7 @@ data GenCmmDecl d h g
d
type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph
+
type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
type RawCmmDecl
@@ -264,4 +265,3 @@ instance Outputable instr => Outputable (GenBasicBlock instr) where
pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
pprBBlock (BasicBlock ident stmts) =
hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
-
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -40,7 +40,7 @@ module GHC.Cmm.CLabel (
mkAsmTempDerivedLabel,
mkAsmTempEndLabel,
mkAsmTempDieLabel,
-
+ mkUnliftedDataLabel,
mkDirty_MUT_VAR_Label,
mkNonmovingWriteBarrierEnabledLabel,
mkUpdInfoLabel,
@@ -251,7 +251,6 @@ data CLabel
-- | A label before an info table to prevent excessive dead-stripping on darwin
| DeadStripPreventer CLabel
-
-- | Per-module table of tick locations
| HpcTicksLabel Module
@@ -263,8 +262,14 @@ data CLabel
| LargeBitmapLabel
{-# UNPACK #-} !Unique
+ -- | Static data from local definitions allocated in the data section,
+ -- arising from a primop, like 'arrayOf#'
+ | UnliftedDataLabel {-# UNPACK #-} !Unique PrimOp
deriving Eq
+mkUnliftedDataLabel :: Unique -> PrimOp -> CLabel
+mkUnliftedDataLabel = UnliftedDataLabel
+
isIdLabel :: CLabel -> Bool
isIdLabel IdLabel{} = True
isIdLabel _ = False
@@ -318,6 +323,8 @@ instance Ord CLabel where
nonDetCmpUnique u1 u2
compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) =
nonDetCmpUnique u1 u2
+ compare (UnliftedDataLabel u1 _) (UnliftedDataLabel u2 _) =
+ nonDetCmpUnique u1 u2
compare IdLabel{} _ = LT
compare _ IdLabel{} = GT
compare CmmLabel{} _ = LT
@@ -348,6 +355,8 @@ instance Ord CLabel where
compare _ HpcTicksLabel{} = GT
compare SRTLabel{} _ = LT
compare _ SRTLabel{} = GT
+ compare UnliftedDataLabel{} _ = LT
+ compare _ UnliftedDataLabel{} = GT
-- | Record where a foreign label is stored.
data ForeignLabelSource
@@ -622,6 +631,8 @@ isStaticClosureLabel :: CLabel -> Bool
isStaticClosureLabel (IdLabel _ _ Closure) = True
-- Closure defined in cmm
isStaticClosureLabel (CmmLabel _ _ CmmClosure) = True
+-- Unlifted data allocated in the data
+isStaticClosureLabel UnliftedDataLabel{} = True
isStaticClosureLabel _lbl = False
-- | Whether label is a .rodata label
@@ -716,6 +727,7 @@ mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die")
toClosureLbl :: CLabel -> CLabel
toClosureLbl (IdLabel n c _) = IdLabel n c Closure
toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure
+toClosureLbl l at UnliftedDataLabel{} = l
toClosureLbl l = pprPanic "toClosureLbl" (ppr l)
toSlowEntryLbl :: CLabel -> CLabel
@@ -775,7 +787,7 @@ hasCAF _ = False
-- -----------------------------------------------------------------------------
-- Does a CLabel need declaring before use or not?
--
--- See wiki:commentary/compiler/backends/ppr-c#prototypes
+-- See wiki: https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/backends/ppr-c#prototypes
needsCDecl :: CLabel -> Bool
-- False <=> it's pre-declared; don't bother
@@ -803,10 +815,11 @@ needsCDecl l@(ForeignLabel{}) = not (isMathFun l)
needsCDecl (CC_Label _) = True
needsCDecl (CCS_Label _) = True
needsCDecl (HpcTicksLabel _) = True
+needsCDecl UnliftedDataLabel{} = True
+
needsCDecl (DynamicLinkerLabel {}) = panic "needsCDecl DynamicLinkerLabel"
needsCDecl PicBaseLabel = panic "needsCDecl PicBaseLabel"
needsCDecl (DeadStripPreventer {}) = panic "needsCDecl DeadStripPreventer"
-
-- | If a label is a local block label then return just its 'BlockId', otherwise
-- 'Nothing'.
maybeLocalBlockLabel :: CLabel -> Maybe BlockId
@@ -928,6 +941,7 @@ externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True
externallyVisibleCLabel (LargeBitmapLabel _) = False
externallyVisibleCLabel (SRTLabel _) = False
+externallyVisibleCLabel UnliftedDataLabel{} = False
externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"
externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"
@@ -988,6 +1002,7 @@ labelType PicBaseLabel = DataLabel
labelType (DeadStripPreventer _) = DataLabel
labelType (HpcTicksLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel
+labelType UnliftedDataLabel{} = GcPtrLabel
idInfoLabelType :: IdLabelInfo -> CLabelType
idInfoLabelType info =
@@ -1295,7 +1310,7 @@ pprCLbl dflags = \case
(CC_Label cc) -> ppr cc
(CCS_Label ccs) -> ppr ccs
(HpcTicksLabel mod) -> text "_hpc_tickboxes_" <> ppr mod <> ptext (sLit "_hpc")
-
+ (UnliftedDataLabel u op) -> tempLabelPrefixOrUnderscore <> ppr op <> pprUniqueAlways u
(AsmTempLabel {}) -> panic "pprCLbl AsmTempLabel"
(AsmTempDerivedLabel {}) -> panic "pprCLbl AsmTempDerivedLabel"
(DynamicLinkerLabel {}) -> panic "pprCLbl DynamicLinkerLabel"
=====================================
compiler/GHC/Cmm/Info/Build.hs
=====================================
@@ -47,8 +47,8 @@ import GHC.Types.Name.Set
{- Note [SRTs]
-SRTs are the mechanism by which the garbage collector can determine
-the live CAFs in the program.
+Static Reference Tables (SRTs) are the mechanism by which the garbage collector
+can determine the live CAFs in the program.
Representation
^^^^^^^^^^^^^^
@@ -481,9 +481,7 @@ addCafLabel l s
| otherwise
= s
-cafAnalData
- :: CmmStatics
- -> CAFSet
+cafAnalData :: CmmStatics -> CAFSet
cafAnalData (CmmStaticsRaw _lbl _data) =
Set.empty
@@ -1111,7 +1109,6 @@ buildSRTChain dflags cafSet =
where
mAX_SRT_SIZE = 16
-
buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)
buildSRT dflags refs = do
id <- getUniqueM
@@ -1121,6 +1118,7 @@ buildSRT dflags refs = do
srt_n_info = mkSRTInfoLabel (length refs)
fields =
mkStaticClosure dflags srt_n_info dontCareCCS
+ [] -- no header
[ CmmLabel lbl | SRTEntry lbl <- refs ]
[] -- no padding
[mkIntCLit platform 0] -- link field
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -423,7 +423,7 @@ static :: { CmmParse [CmmStatic] }
mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
-- mkForeignLabel because these are only used
-- for CHARLIKE and INTLIKE closures in the RTS.
- dontCareCCS (map getLit lits) [] [] [] } }
+ dontCareCCS (map getLit lits) [] [] [] [] } }
-- arrays of closures required for the CHARLIKE & INTLIKE arrays
lits :: { [CmmParse CmmExpr] }
@@ -1166,7 +1166,7 @@ profilingInfo dflags desc_str ty_str
staticClosure :: Unit -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure pkg cl_label info payload
= do dflags <- getDynFlags
- let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
+ let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] []
code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
foreignCall
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -740,5 +740,3 @@ mkUnsafeCoercePrimPair _old_id old_expr
id = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info
; return (id, old_expr) }
-
- where
=====================================
compiler/GHC/Stg/Pipeline.hs
=====================================
@@ -32,6 +32,7 @@ import GHC.Utils.Outputable
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.State.Strict
+import Data.Maybe (catMaybes)
newtype StgM a = StgM { _unStgM :: StateT Char IO a }
deriving (Functor, Applicative, Monad, MonadIO)
@@ -80,9 +81,6 @@ stg2stg dflags this_mod binds
do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]
do_stg_pass binds to_do
= case to_do of
- StgDoNothing ->
- return binds
-
StgStats ->
trace (showStgStats binds) (return binds)
@@ -126,24 +124,20 @@ data StgToDo
| StgStats
| StgUnarise
-- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders
- | StgDoNothing
- -- ^ Useful for building up 'getStgToDo'
deriving Eq
-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.
getStgToDo :: DynFlags -> [StgToDo]
-getStgToDo dflags =
- filter (/= StgDoNothing)
+getStgToDo dflags = catMaybes
[ mandatory StgUnarise
-- Important that unarisation comes first
-- See Note [StgCse after unarisation] in GHC.Stg.CSE
, optional Opt_StgCSE StgCSE
, optional Opt_StgLiftLams StgLiftLams
, optional Opt_StgStats StgStats
- ] where
- optional opt = runWhen (gopt opt dflags)
- mandatory = id
-
-runWhen :: Bool -> StgToDo -> StgToDo
-runWhen True todo = todo
-runWhen _ _ = StgDoNothing
+ ]
+ where
+ optional opt x
+ | gopt opt dflags = Just x
+ | otherwise = Nothing
+ mandatory = Just
=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -60,6 +60,7 @@ module GHC.StgToCmm.Closure (
cafBlackHoleInfoTable,
indStaticInfoTable,
staticClosureNeedsLink,
+ smallArrayStaticInfoTable,
) where
#include "HsVersions.h"
@@ -986,6 +987,14 @@ indStaticInfoTable
, cit_srt = Nothing
, cit_clo = Nothing }
+smallArrayStaticInfoTable :: WordOff -> CmmInfoTable
+smallArrayStaticInfoTable n
+ = CmmInfoTable { cit_lbl = mkSMAP_FROZEN_DIRTY_infoLabel
+ , cit_rep = smallArrPtrsRep (fromIntegral n)
+ , cit_prof = NoProfilingInfo
+ , cit_srt = Nothing
+ , cit_clo = Nothing }
+
staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
-- A static closure needs a link field to aid the GC when traversing
-- the static closure graph. But it only needs such a field if either
=====================================
compiler/GHC/StgToCmm/Heap.hs
=====================================
@@ -174,11 +174,13 @@ mkStaticClosureFields
-> [CmmLit] -- Payload
-> [CmmLit] -- The full closure
mkStaticClosureFields dflags info_tbl ccs caf_refs payload
- = mkStaticClosure dflags info_lbl ccs payload padding
+ = mkStaticClosure dflags (cit_lbl info_tbl) ccs header payload padding
static_link_field saved_info_field
where
platform = targetPlatform dflags
- info_lbl = cit_lbl info_tbl
+ header = case cit_rep info_tbl of
+ SmallArrayPtrsRep size -> [mkIntCLit (targetPlatform dflags) size]
+ _ -> []
-- CAFs must have consistent layout, regardless of whether they
-- are actually updatable or not. The layout of a CAF is:
@@ -219,11 +221,12 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload
-- See Note [STATIC_LINK fields]
-- in rts/sm/Storage.h
-mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]
+mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] -> [CmmLit]
-> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
-mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field
+mkStaticClosure dflags info_lbl ccs header payload padding static_link_field saved_info_field
= [CmmLabel info_lbl]
++ staticProfHdr dflags ccs
+ ++ header
++ payload
++ padding
++ static_link_field
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -57,6 +57,9 @@ import Data.Maybe
import Data.Bits ((.&.), bit)
import Control.Monad (liftM, when, unless)
+import GHC.Types.CostCentre (dontCareCCS)
+import GHC.StgToCmm.Closure
+
------------------------------------------------------------------------
-- Primitive operations and foreign calls
------------------------------------------------------------------------
@@ -238,18 +241,30 @@ emitPrimOp dflags = \case
[ (mkIntExpr platform (fromInteger n),
fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)
]
- (replicate (fromIntegral n) init)
+ (replicate (fromIntegral n) init)
_ -> PrimopCmmEmit_External
- SmallArrayOfOp -> \elems -> opAllDone $ \[res] ->
+ op at SmallArrayOfOp -> \elems -> opAllDone $ \[res] -> do
let n = length elems
- in doNewArrayOp
- res
- (smallArrPtrsRep (fromIntegral n))
- mkSMAP_FROZEN_DIRTY_infoLabel
- [ ( mkIntExpr platform n
- , fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags ) ]
- elems
+ case allStatic elems of
+ Just known -> do
+ u <- newUnique
+ let lbl = mkUnliftedDataLabel u op
+ emitDataCon lbl (smallArrayStaticInfoTable n) dontCareCCS known
+ emit $ mkAssign (CmmLocal res) (CmmLit $ CmmLabel lbl)
+ Nothing -> doNewArrayOp
+ res
+ (smallArrPtrsRep (fromIntegral n))
+ mkSMAP_FROZEN_DIRTY_infoLabel
+ [ ( mkIntExpr platform n
+ , fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags ) ]
+ elems
+ where
+ -- todo: comment
+ allStatic = foldr step (Just [])
+
+ step (CmmLit l) (Just acc) = Just (l : acc) -- c.f. XXX getLit
+ step _ _ = Nothing
CopySmallArrayOp -> \case
[src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->
=====================================
includes/rts/storage/Closures.h
=====================================
@@ -166,7 +166,7 @@ typedef struct {
typedef struct {
StgHeader header;
- StgWord ptrs;
+ StgWord ptrs; // number of elems
StgWord size; // ptrs plus card table
StgClosure *payload[];
// see also: StgMutArrPtrs macros in ClosureMacros.h
@@ -174,7 +174,7 @@ typedef struct {
typedef struct {
StgHeader header;
- StgWord ptrs;
+ StgWord ptrs; // number of elems
StgClosure *payload[];
} StgSmallMutArrPtrs;
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/79e80ab3c4e094db663186c159ba3ca90b2d0c37...a810d2065d5844394754712161e4352d6fc8efd0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/79e80ab3c4e094db663186c159ba3ca90b2d0c37...a810d2065d5844394754712161e4352d6fc8efd0
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200622/c27c65bf/attachment-0001.html>
More information about the ghc-commits
mailing list