[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Don't rely on CLabel's Outputable instance in CmmToC
Marge Bot
gitlab at gitlab.haskell.org
Fri Sep 4 03:33:40 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
25b4604a by Sylvain Henry at 2020-09-03T23:33:28-04:00
Don't rely on CLabel's Outputable instance in CmmToC
This is in preparation of the removal of sdocWithDynFlags (#10143),
hence of the refactoring of CLabel's Outputable instance.
- - - - -
d8ee2429 by Sylvain Henry at 2020-09-03T23:33:30-04:00
DynFlags: use Platform in foldRegs*
- - - - -
ff888421 by Sylvain Henry at 2020-09-03T23:33:30-04:00
DynFlags: don't pass DynFlags to cmmImplementSwitchPlans
- - - - -
ff8a6dea by Ryan Scott at 2020-09-03T23:33:30-04:00
Introduce isBoxedTupleDataCon and use it to fix #18644
The code that converts promoted tuple data constructors to
`IfaceType`s in `GHC.CoreToIface` was using `isTupleDataCon`, which
conflates boxed and unboxed tuple data constructors. To avoid this,
this patch introduces `isBoxedTupleDataCon`, which is like
`isTupleDataCon` but only works for _boxed_ tuple data constructors.
While I was in town, I was horribly confused by the fact that there
were separate functions named `isUnboxedTupleCon` and
`isUnboxedTupleTyCon` (similarly, `isUnboxedSumCon` and
`isUnboxedSumTyCon`). It turns out that the former only works for
data constructors, despite its very general name! I opted to rename
`isUnboxedTupleCon` to `isUnboxedTupleDataCon` (similarly, I renamed
`isUnboxedSumCon` to `isUnboxedSumDataCon`) to avoid this potential
confusion, as well as to be more consistent with
the naming convention I used for `isBoxedTupleDataCon`.
Fixes #18644.
- - - - -
30 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/Expr.hs
- compiler/GHC/Cmm/LayoutStack.hs
- compiler/GHC/Cmm/Lint.hs
- compiler/GHC/Cmm/Liveness.hs
- compiler/GHC/Cmm/Node.hs
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/Cmm/ProcPoint.hs
- compiler/GHC/Cmm/Sink.hs
- compiler/GHC/Cmm/Switch/Implement.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/DataCon.hs-boot
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/CoreToByteCode.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/HsToCore/PmCheck/Ppr.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/StgToCmm/DataCon.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/Types/Id.hs
- + testsuite/tests/ghci/scripts/T18644.script
- + testsuite/tests/ghci/scripts/T18644.stdout
- testsuite/tests/ghci/scripts/all.T
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -108,7 +108,7 @@ module GHC.Cmm.CLabel (
-- * Conversions
toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,
- pprCLabel, pprCLabel_LLVM, pprCLabel_NCG,
+ pprCLabel, pprCLabel_LLVM, pprCLabel_NCG, pprCLabel_ViaC,
isInfoTableLabel,
isConInfoTableLabel,
isIdLabel, isTickyLabel
@@ -1218,11 +1218,15 @@ pprCLabel bcknd platform lbl =
case bcknd of
NCG -> pprCLabel_NCG platform lbl
LLVM -> pprCLabel_LLVM platform lbl
+ ViaC -> pprCLabel_ViaC platform lbl
_ -> pprCLabel_other platform lbl
pprCLabel_LLVM :: Platform -> CLabel -> SDoc
pprCLabel_LLVM = pprCLabel_NCG
+pprCLabel_ViaC :: Platform -> CLabel -> SDoc
+pprCLabel_ViaC = pprCLabel_other
+
pprCLabel_NCG :: Platform -> CLabel -> SDoc
pprCLabel_NCG platform lbl = getPprStyle $ \sty ->
let
@@ -1348,7 +1352,13 @@ pprCLabel_common platform = \case
(ForeignLabel str _ _ _) -> ftext str
- (IdLabel name _cafs flavor) -> internalNamePrefix platform name <> ppr name <> ppIdFlavor flavor
+ (IdLabel name _cafs flavor) -> internalNamePrefix <> ppr name <> ppIdFlavor flavor
+ where
+ isRandomGenerated = not (isExternalName name)
+ internalNamePrefix = getPprStyle $ \ sty ->
+ if asmStyle sty && isRandomGenerated
+ then ptext (asmTempLabelPrefix platform)
+ else empty
(CC_Label cc) -> ppr cc
(CCS_Label ccs) -> ppr ccs
@@ -1389,15 +1399,6 @@ instance Outputable ForeignLabelSource where
ForeignLabelInThisPackage -> parens $ text "this package"
ForeignLabelInExternalPackage -> parens $ text "external package"
-internalNamePrefix :: Platform -> Name -> SDoc
-internalNamePrefix platform name = getPprStyle $ \ sty ->
- if asmStyle sty && isRandomGenerated then
- ptext (asmTempLabelPrefix platform)
- else
- empty
- where
- isRandomGenerated = not $ isExternalName name
-
tempLabelPrefixOrUnderscore :: Platform -> SDoc
tempLabelPrefixOrUnderscore platform =
getPprStyle $ \ sty ->
=====================================
compiler/GHC/Cmm/Expr.hs
=====================================
@@ -38,7 +38,6 @@ import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.MachOp
import GHC.Cmm.Type
-import GHC.Driver.Session
import GHC.Utils.Panic (panic)
import GHC.Types.Unique
@@ -331,17 +330,17 @@ sizeRegSet = Set.size
regSetToList = Set.toList
class Ord r => UserOfRegs r a where
- foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b
+ foldRegsUsed :: Platform -> (b -> r -> b) -> b -> a -> b
foldLocalRegsUsed :: UserOfRegs LocalReg a
- => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
+ => Platform -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsUsed = foldRegsUsed
class Ord r => DefinerOfRegs r a where
- foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b
+ foldRegsDefd :: Platform -> (b -> r -> b) -> b -> a -> b
foldLocalRegsDefd :: DefinerOfRegs LocalReg a
- => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
+ => Platform -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsDefd = foldRegsDefd
instance UserOfRegs LocalReg CmmReg where
@@ -369,20 +368,20 @@ instance Ord r => DefinerOfRegs r r where
instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
-- The (Ord r) in the context is necessary here
-- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance
- foldRegsUsed dflags f !z e = expr z e
+ foldRegsUsed platform f !z e = expr z e
where expr z (CmmLit _) = z
- expr z (CmmLoad addr _) = foldRegsUsed dflags f z addr
- expr z (CmmReg r) = foldRegsUsed dflags f z r
- expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs
- expr z (CmmRegOff r _) = foldRegsUsed dflags f z r
+ expr z (CmmLoad addr _) = foldRegsUsed platform f z addr
+ expr z (CmmReg r) = foldRegsUsed platform f z r
+ expr z (CmmMachOp _ exprs) = foldRegsUsed platform f z exprs
+ expr z (CmmRegOff r _) = foldRegsUsed platform f z r
expr z (CmmStackSlot _ _) = z
instance UserOfRegs r a => UserOfRegs r [a] where
- foldRegsUsed dflags f set as = foldl' (foldRegsUsed dflags f) set as
+ foldRegsUsed platform f set as = foldl' (foldRegsUsed platform f) set as
{-# INLINABLE foldRegsUsed #-}
instance DefinerOfRegs r a => DefinerOfRegs r [a] where
- foldRegsDefd dflags f set as = foldl' (foldRegsDefd dflags f) set as
+ foldRegsDefd platform f set as = foldl' (foldRegsDefd platform f) set as
{-# INLINABLE foldRegsDefd #-}
-----------------------------------------------------------------------------
=====================================
compiler/GHC/Cmm/LayoutStack.hs
=====================================
@@ -246,9 +246,10 @@ cmmLayoutStack dflags procpoints entry_args
= do
-- We need liveness info. Dead assignments are removed later
-- by the sinking pass.
- let liveness = cmmLocalLiveness dflags graph
+ let liveness = cmmLocalLiveness platform graph
blocks = revPostorder graph
- profile = targetProfile dflags
+ profile = targetProfile dflags
+ platform = profilePlatform profile
(final_stackmaps, _final_high_sp, new_blocks) <-
mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
@@ -256,7 +257,7 @@ cmmLayoutStack dflags procpoints entry_args
rec_stackmaps rec_high_sp blocks
blocks_with_reloads <-
- insertReloadsAsNeeded dflags procpoints final_stackmaps entry new_blocks
+ insertReloadsAsNeeded platform procpoints final_stackmaps entry new_blocks
new_blocks' <- mapM (lowerSafeForeignCall profile) blocks_with_reloads
return (ofBlockList entry new_blocks', final_stackmaps)
@@ -1044,30 +1045,29 @@ stackMapToLiveness platform StackMap{..} =
-- -----------------------------------------------------------------------------
insertReloadsAsNeeded
- :: DynFlags
+ :: Platform
-> ProcPointSet
-> LabelMap StackMap
-> BlockId
-> [CmmBlock]
-> UniqSM [CmmBlock]
-insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do
+insertReloadsAsNeeded platform procpoints final_stackmaps entry blocks = do
toBlockList . fst <$>
rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty
where
rewriteCC :: RewriteFun CmmLocalLive
rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do
let entry_label = entryLabel e_node
- platform = targetPlatform dflags
stackmap = case mapLookup entry_label final_stackmaps of
Just sm -> sm
Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap"
-- Merge the liveness from successor blocks and analyse the last
-- node.
- joined = gen_kill dflags x_node $!
+ joined = gen_kill platform x_node $!
joinOutFacts liveLattice x_node fact_base0
-- What is live at the start of middle0.
- live_at_middle0 = foldNodesBwdOO (gen_kill dflags) middle0 joined
+ live_at_middle0 = foldNodesBwdOO (gen_kill platform) middle0 joined
-- If this is a procpoint we need to add the reloads, but only if
-- they're actually live. Furthermore, nothing is live at the entry
=====================================
compiler/GHC/Cmm/Lint.hs
=====================================
@@ -26,7 +26,6 @@ import GHC.Cmm.Liveness
import GHC.Cmm.Switch (switchTargetsToList)
import GHC.Cmm.Ppr () -- For Outputable instances
import GHC.Utils.Outputable
-import GHC.Driver.Session
import Control.Monad (ap, unless)
@@ -39,37 +38,38 @@ import Control.Monad (ap, unless)
-- Exported entry points:
cmmLint :: (Outputable d, Outputable h)
- => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
-cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops
+ => Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc
+cmmLint platform tops = runCmmLint platform (mapM_ lintCmmDecl) tops
-cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc
-cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g
+cmmLintGraph :: Platform -> CmmGraph -> Maybe SDoc
+cmmLintGraph platform g = runCmmLint platform lintCmmGraph g
-runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
-runCmmLint dflags l p =
- case unCL (l p) dflags of
+runCmmLint :: Outputable a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
+runCmmLint platform l p =
+ case unCL (l p) platform of
Left err -> Just (vcat [text "Cmm lint error:",
nest 2 err,
text "Program was:",
nest 2 (ppr p)])
Right _ -> Nothing
-lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()
-lintCmmDecl dflags (CmmProc _ lbl _ g)
- = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g
-lintCmmDecl _ (CmmData {})
+lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint ()
+lintCmmDecl (CmmProc _ lbl _ g)
+ = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph g
+lintCmmDecl (CmmData {})
= return ()
-lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()
-lintCmmGraph dflags g =
- cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks
- -- cmmLiveness throws an error if there are registers
- -- live on entry to the graph (i.e. undefined
- -- variables)
- where
- blocks = toBlockList g
- labels = setFromList (map entryLabel blocks)
+lintCmmGraph :: CmmGraph -> CmmLint ()
+lintCmmGraph g = do
+ platform <- getPlatform
+ let
+ blocks = toBlockList g
+ labels = setFromList (map entryLabel blocks)
+ cmmLocalLiveness platform g `seq` mapM_ (lintCmmBlock labels) blocks
+ -- cmmLiveness throws an error if there are registers
+ -- live on entry to the graph (i.e. undefined
+ -- variables)
lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()
@@ -225,9 +225,9 @@ lintTarget (PrimTarget {}) = return ()
mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, Outputable a)
=> SDoc -> a -> CmmLint ()
mayNotMentionCallerSavedRegs what thing = do
- dflags <- getDynFlags
- let badRegs = filter (callerSaves (targetPlatform dflags))
- $ foldRegsUsed dflags (flip (:)) [] thing
+ platform <- getPlatform
+ let badRegs = filter (callerSaves platform)
+ $ foldRegsUsed platform (flip (:)) [] thing
unless (null badRegs)
$ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ ppr thing)
@@ -243,7 +243,7 @@ checkCond _ expr
-- just a basic error monad:
-newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }
+newtype CmmLint a = CmmLint { unCL :: Platform -> Either SDoc a }
deriving (Functor)
instance Applicative CmmLint where
@@ -251,23 +251,20 @@ instance Applicative CmmLint where
(<*>) = ap
instance Monad CmmLint where
- CmmLint m >>= k = CmmLint $ \dflags ->
- case m dflags of
+ CmmLint m >>= k = CmmLint $ \platform ->
+ case m platform of
Left e -> Left e
- Right a -> unCL (k a) dflags
-
-instance HasDynFlags CmmLint where
- getDynFlags = CmmLint (\dflags -> Right dflags)
+ Right a -> unCL (k a) platform
getPlatform :: CmmLint Platform
-getPlatform = targetPlatform <$> getDynFlags
+getPlatform = CmmLint $ \platform -> Right platform
cmmLintErr :: SDoc -> CmmLint a
cmmLintErr msg = CmmLint (\_ -> Left msg)
addLintInfo :: SDoc -> CmmLint a -> CmmLint a
-addLintInfo info thing = CmmLint $ \dflags ->
- case unCL thing dflags of
+addLintInfo info thing = CmmLint $ \platform ->
+ case unCL thing platform of
Left err -> Left (hang info 2 err)
Right a -> Right a
=====================================
compiler/GHC/Cmm/Liveness.hs
=====================================
@@ -14,7 +14,7 @@ where
import GHC.Prelude
-import GHC.Driver.Session
+import GHC.Platform
import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.Ppr.Expr () -- For Outputable instances
@@ -52,17 +52,17 @@ type BlockEntryLiveness r = LabelMap (CmmLive r)
-- | Calculated liveness info for a CmmGraph
-----------------------------------------------------------------------------
-cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg
-cmmLocalLiveness dflags graph =
- check $ analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty
+cmmLocalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness LocalReg
+cmmLocalLiveness platform graph =
+ check $ analyzeCmmBwd liveLattice (xferLive platform) graph mapEmpty
where
entry = g_entry graph
check facts =
noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts
-cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg
-cmmGlobalLiveness dflags graph =
- analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty
+cmmGlobalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness GlobalReg
+cmmGlobalLiveness platform graph =
+ analyzeCmmBwd liveLattice (xferLive platform) graph mapEmpty
-- | On entry to the procedure, there had better not be any LocalReg's live-in.
noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a
@@ -72,10 +72,10 @@ noLiveOnEntry bid in_fact x =
gen_kill
:: (DefinerOfRegs r n, UserOfRegs r n)
- => DynFlags -> n -> CmmLive r -> CmmLive r
-gen_kill dflags node set =
- let !afterKill = foldRegsDefd dflags deleteFromRegSet set node
- in foldRegsUsed dflags extendRegSet afterKill node
+ => Platform -> n -> CmmLive r -> CmmLive r
+gen_kill platform node set =
+ let !afterKill = foldRegsDefd platform deleteFromRegSet set node
+ in foldRegsUsed platform extendRegSet afterKill node
{-# INLINE gen_kill #-}
xferLive
@@ -85,10 +85,10 @@ xferLive
, UserOfRegs r (CmmNode O C)
, DefinerOfRegs r (CmmNode O C)
)
- => DynFlags -> TransferFun (CmmLive r)
-xferLive dflags (BlockCC eNode middle xNode) fBase =
- let joined = gen_kill dflags xNode $! joinOutFacts liveLattice xNode fBase
- !result = foldNodesBwdOO (gen_kill dflags) middle joined
+ => Platform -> TransferFun (CmmLive r)
+xferLive platform (BlockCC eNode middle xNode) fBase =
+ let joined = gen_kill platform xNode $! joinOutFacts liveLattice xNode fBase
+ !result = foldNodesBwdOO (gen_kill platform) middle joined
in mapSingleton (entryLabel eNode) result
-{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive LocalReg) #-}
-{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive GlobalReg) #-}
+{-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive LocalReg) #-}
+{-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive GlobalReg) #-}
=====================================
compiler/GHC/Cmm/Node.hs
=====================================
@@ -31,7 +31,6 @@ import GHC.Prelude hiding (succ)
import GHC.Platform.Regs
import GHC.Cmm.Expr
import GHC.Cmm.Switch
-import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Types.ForeignCall
import GHC.Utils.Outputable
@@ -320,7 +319,7 @@ foreignTargetHints target
-- Instances of register and slot users / definers
instance UserOfRegs LocalReg (CmmNode e x) where
- foldRegsUsed dflags f !z n = case n of
+ foldRegsUsed platform f !z n = case n of
CmmAssign _ expr -> fold f z expr
CmmStore addr rval -> fold f (fold f z addr) rval
CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
@@ -331,10 +330,10 @@ instance UserOfRegs LocalReg (CmmNode e x) where
_ -> z
where fold :: forall a b. UserOfRegs LocalReg a
=> (b -> LocalReg -> b) -> b -> a -> b
- fold f z n = foldRegsUsed dflags f z n
+ fold f z n = foldRegsUsed platform f z n
instance UserOfRegs GlobalReg (CmmNode e x) where
- foldRegsUsed dflags f !z n = case n of
+ foldRegsUsed platform f !z n = case n of
CmmAssign _ expr -> fold f z expr
CmmStore addr rval -> fold f (fold f z addr) rval
CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
@@ -345,26 +344,26 @@ instance UserOfRegs GlobalReg (CmmNode e x) where
_ -> z
where fold :: forall a b. UserOfRegs GlobalReg a
=> (b -> GlobalReg -> b) -> b -> a -> b
- fold f z n = foldRegsUsed dflags f z n
+ fold f z n = foldRegsUsed platform f z n
instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where
-- The (Ord r) in the context is necessary here
-- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance
- foldRegsUsed _ _ !z (PrimTarget _) = z
- foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e
+ foldRegsUsed _ _ !z (PrimTarget _) = z
+ foldRegsUsed platform f !z (ForeignTarget e _) = foldRegsUsed platform f z e
instance DefinerOfRegs LocalReg (CmmNode e x) where
- foldRegsDefd dflags f !z n = case n of
+ foldRegsDefd platform f !z n = case n of
CmmAssign lhs _ -> fold f z lhs
CmmUnsafeForeignCall _ fs _ -> fold f z fs
CmmForeignCall {res=res} -> fold f z res
_ -> z
where fold :: forall a b. DefinerOfRegs LocalReg a
=> (b -> LocalReg -> b) -> b -> a -> b
- fold f z n = foldRegsDefd dflags f z n
+ fold f z n = foldRegsDefd platform f z n
instance DefinerOfRegs GlobalReg (CmmNode e x) where
- foldRegsDefd dflags f !z n = case n of
+ foldRegsDefd platform f !z n = case n of
CmmAssign lhs _ -> fold f z lhs
CmmUnsafeForeignCall tgt _ _ -> fold f z (foreignTargetRegs tgt)
CmmCall {} -> fold f z activeRegs
@@ -373,9 +372,8 @@ instance DefinerOfRegs GlobalReg (CmmNode e x) where
_ -> z
where fold :: forall a b. DefinerOfRegs GlobalReg a
=> (b -> GlobalReg -> b) -> b -> a -> b
- fold f z n = foldRegsDefd dflags f z n
+ fold f z n = foldRegsDefd platform f z n
- platform = targetPlatform dflags
activeRegs = activeStgRegs platform
activeCallerSavesRegs = filter (callerSaves platform) activeRegs
=====================================
compiler/GHC/Cmm/Pipeline.hs
=====================================
@@ -86,7 +86,7 @@ cpsTop dflags proc =
----------- Implement switches ------------------------------------------
g <- {-# SCC "createSwitchPlans" #-}
- runUniqSM $ cmmImplementSwitchPlans dflags g
+ runUniqSM $ cmmImplementSwitchPlans (backend dflags) platform g
dump Opt_D_dump_cmm_switch "Post switch plan" g
----------- Proc points -------------------------------------------------
@@ -97,7 +97,7 @@ cpsTop dflags proc =
if splitting_proc_points
then do
pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
- minimalProcPointSet (targetPlatform dflags) call_pps g
+ minimalProcPointSet platform call_pps g
dumpWith dflags Opt_D_dump_cmm_proc "Proc points"
FormatCMM (ppr l $$ ppr pp $$ ppr g)
return pp
@@ -114,7 +114,7 @@ cpsTop dflags proc =
----------- Sink and inline assignments --------------------------------
g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]
- condPass Opt_CmmSink (cmmSink dflags) g
+ condPass Opt_CmmSink (cmmSink platform) g
Opt_D_dump_cmm_sink "Sink assignments"
------------- CAF analysis ----------------------------------------------
@@ -129,7 +129,7 @@ cpsTop dflags proc =
dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map"
FormatCMM (ppr pp_map)
g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
- splitAtProcPoints dflags l call_pps proc_points pp_map
+ splitAtProcPoints platform l call_pps proc_points pp_map
(CmmProc h l v g)
dumps Opt_D_dump_cmm_split "Post splitting" g
return g
@@ -355,7 +355,7 @@ dumpGraph dflags flag name g = do
when (gopt Opt_DoCmmLinting dflags) $ do_lint g
dumpWith dflags flag name FormatCMM (ppr g)
where
- do_lint g = case cmmLintGraph dflags g of
+ do_lint g = case cmmLintGraph (targetPlatform dflags) g of
Just err -> do { fatalErrorMsg dflags err
; ghcExit dflags 1
}
=====================================
compiler/GHC/Cmm/ProcPoint.hs
=====================================
@@ -11,7 +11,6 @@ where
import GHC.Prelude hiding (last, unzip, succ, zip)
-import GHC.Driver.Session
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm
@@ -238,9 +237,9 @@ extendPPSet platform g blocks procPoints =
-- Input invariant: A block should only be reachable from a single ProcPoint.
-- ToDo: use the _ret naming convention that the old code generator
-- used. -- EZY
-splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->
+splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->
CmmDecl -> UniqSM [CmmDecl]
-splitAtProcPoints dflags entry_label callPPs procPoints procMap
+splitAtProcPoints platform entry_label callPPs procPoints procMap
(CmmProc (TopInfo {info_tbls = info_tbls})
top_l _ g@(CmmGraph {g_entry=entry})) =
do -- Build a map from procpoints to the blocks they reach
@@ -262,7 +261,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
where graph = mapLookup procId graphEnv `orElse` mapEmpty
graph' = mapInsert bid b graph
- let liveness = cmmGlobalLiveness dflags g
+ let liveness = cmmGlobalLiveness platform g
let ppLiveness pp = filter isArgReg $
regSetToList $
expectJust "ppLiveness" $ mapLookup pp liveness
@@ -316,7 +315,6 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
-- when jumping to a PP that has an info table, if
-- tablesNextToCode is off we must jump to the entry
-- label instead.
- platform = targetPlatform dflags
tablesNextToCode = platformTablesNextToCode platform
jump_label (Just info_lbl) _
| tablesNextToCode = info_lbl
=====================================
compiler/GHC/Cmm/Sink.hs
=====================================
@@ -16,7 +16,6 @@ import GHC.Cmm.Dataflow.Graph
import GHC.Platform.Regs
import GHC.Platform
-import GHC.Driver.Session
import GHC.Types.Unique
import GHC.Types.Unique.FM
@@ -165,10 +164,10 @@ type Assignments = [Assignment]
-- y = e2
-- x = e1
-cmmSink :: DynFlags -> CmmGraph -> CmmGraph
-cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
+cmmSink :: Platform -> CmmGraph -> CmmGraph
+cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
where
- liveness = cmmLocalLiveness dflags graph
+ liveness = cmmLocalLiveness platform graph
getLive l = mapFindWithDefault Set.empty l liveness
blocks = revPostorder graph
@@ -181,7 +180,6 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
-- pprTrace "sink" (ppr lbl) $
blockJoin first final_middle final_last : sink sunk' bs
where
- platform = targetPlatform dflags
lbl = entryLabel b
(first, middle, last) = blockSplit b
@@ -191,13 +189,13 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
-- the node. This will help us decide whether we can inline
-- an assignment in the current node or not.
live = Set.unions (map getLive succs)
- live_middle = gen_kill dflags last live
- ann_middles = annotate dflags live_middle (blockToList middle)
+ live_middle = gen_kill platform last live
+ ann_middles = annotate platform live_middle (blockToList middle)
-- Now sink and inline in this block
- (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk)
+ (middle', assigs) = walk platform ann_middles (mapFindWithDefault [] lbl sunk)
fold_last = constantFoldNode platform last
- (final_last, assigs') = tryToInline dflags live fold_last assigs
+ (final_last, assigs') = tryToInline platform live fold_last assigs
-- We cannot sink into join points (successors with more than
-- one predecessor), so identify the join points and the set
@@ -217,12 +215,12 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
_ -> False
-- Now, drop any assignments that we will not sink any further.
- (dropped_last, assigs'') = dropAssignments dflags drop_if init_live_sets assigs'
+ (dropped_last, assigs'') = dropAssignments platform drop_if init_live_sets assigs'
drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')
where
- should_drop = conflicts dflags a final_last
- || not (isTrivial dflags rhs) && live_in_multi live_sets r
+ should_drop = conflicts platform a final_last
+ || not (isTrivial platform rhs) && live_in_multi live_sets r
|| r `Set.member` live_in_joins
live_sets' | should_drop = live_sets
@@ -231,12 +229,12 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
upd set | r `Set.member` set = set `Set.union` live_rhs
| otherwise = set
- live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs
+ live_rhs = foldRegsUsed platform extendRegSet emptyRegSet rhs
final_middle = foldl' blockSnoc middle' dropped_last
sunk' = mapUnion sunk $
- mapFromList [ (l, filterAssignments dflags (getLive l) assigs'')
+ mapFromList [ (l, filterAssignments platform (getLive l) assigs'')
| l <- succs ]
{- TODO: enable this later, when we have some good tests in place to
@@ -255,12 +253,12 @@ isSmall _ = False
-- We allow duplication of trivial expressions: registers (both local and
-- global) and literals.
--
-isTrivial :: DynFlags -> CmmExpr -> Bool
+isTrivial :: Platform -> CmmExpr -> Bool
isTrivial _ (CmmReg (CmmLocal _)) = True
-isTrivial dflags (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?]
- if isARM (platformArch (targetPlatform dflags))
+isTrivial platform (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?]
+ if isARM (platformArch platform)
then True -- CodeGen.Platform.ARM does not have globalRegMaybe
- else isJust (globalRegMaybe (targetPlatform dflags) r)
+ else isJust (globalRegMaybe platform r)
-- GlobalRegs that are loads from BaseReg are not trivial
isTrivial _ (CmmLit _) = True
isTrivial _ _ = False
@@ -268,9 +266,9 @@ isTrivial _ _ = False
--
-- annotate each node with the set of registers live *after* the node
--
-annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)]
-annotate dflags live nodes = snd $ foldr ann (live,[]) nodes
- where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes)
+annotate :: Platform -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)]
+annotate platform live nodes = snd $ foldr ann (live,[]) nodes
+ where ann n (live,nodes) = (gen_kill platform n live, (live,n) : nodes)
--
-- Find the blocks that have multiple successors (join points)
@@ -287,14 +285,14 @@ findJoinPoints blocks = mapFilter (>1) succ_counts
-- filter the list of assignments to remove any assignments that
-- are not live in a continuation.
--
-filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments
-filterAssignments dflags live assigs = reverse (go assigs [])
+filterAssignments :: Platform -> LocalRegSet -> Assignments -> Assignments
+filterAssignments platform live assigs = reverse (go assigs [])
where go [] kept = kept
go (a@(r,_,_):as) kept | needed = go as (a:kept)
| otherwise = go as kept
where
needed = r `Set.member` live
- || any (conflicts dflags a) (map toNode kept)
+ || any (conflicts platform a) (map toNode kept)
-- Note that we must keep assignments that are
-- referred to by other assignments we have
-- already kept.
@@ -313,7 +311,7 @@ filterAssignments dflags live assigs = reverse (go assigs [])
-- * a list of assignments that will be placed *after* that block.
--
-walk :: DynFlags
+walk :: Platform
-> [(LocalRegSet, CmmNode O O)] -- nodes of the block, annotated with
-- the set of registers live *after*
-- this node.
@@ -327,7 +325,7 @@ walk :: DynFlags
, Assignments -- Assignments to sink further
)
-walk dflags nodes assigs = go nodes emptyBlock assigs
+walk platform nodes assigs = go nodes emptyBlock assigs
where
go [] block as = (block, as)
go ((live,node):ns) block as
@@ -336,13 +334,12 @@ walk dflags nodes assigs = go nodes emptyBlock assigs
| Just a <- shouldSink platform node2 = go ns block (a : as1)
| otherwise = go ns block' as'
where
- platform = targetPlatform dflags
node1 = constantFoldNode platform node
- (node2, as1) = tryToInline dflags live node1 as
+ (node2, as1) = tryToInline platform live node1 as
- (dropped, as') = dropAssignmentsSimple dflags
- (\a -> conflicts dflags a node2) as1
+ (dropped, as') = dropAssignmentsSimple platform
+ (\a -> conflicts platform a node2) as1
block' = foldl' blockSnoc block dropped `blockSnoc` node2
@@ -380,13 +377,13 @@ shouldDiscard node live
toNode :: Assignment -> CmmNode O O
toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs
-dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments
+dropAssignmentsSimple :: Platform -> (Assignment -> Bool) -> Assignments
-> ([CmmNode O O], Assignments)
-dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) ()
+dropAssignmentsSimple platform f = dropAssignments platform (\a _ -> (f a, ())) ()
-dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments
+dropAssignments :: Platform -> (Assignment -> s -> (Bool, s)) -> s -> Assignments
-> ([CmmNode O O], Assignments)
-dropAssignments dflags should_drop state assigs
+dropAssignments platform should_drop state assigs
= (dropped, reverse kept)
where
(dropped,kept) = go state assigs [] []
@@ -397,7 +394,7 @@ dropAssignments dflags should_drop state assigs
| otherwise = go state' rest dropped (assig:kept)
where
(dropit, state') = should_drop assig state
- conflict = dropit || any (conflicts dflags assig) dropped
+ conflict = dropit || any (conflicts platform assig) dropped
-- -----------------------------------------------------------------------------
@@ -406,7 +403,7 @@ dropAssignments dflags should_drop state assigs
-- inlining opens up opportunities for doing so.
tryToInline
- :: DynFlags
+ :: Platform
-> LocalRegSet -- set of registers live after this
-- node. We cannot inline anything
-- that is live after the node, unless
@@ -418,10 +415,10 @@ tryToInline
, Assignments -- Remaining assignments
)
-tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
+tryToInline platform live node assigs = go usages node emptyLRegSet assigs
where
usages :: UniqFM LocalReg Int -- Maps each LocalReg to a count of how often it is used
- usages = foldLocalRegsUsed dflags addUsage emptyUFM node
+ usages = foldLocalRegsUsed platform addUsage emptyUFM node
go _usages node _skipped [] = (node, [])
@@ -429,12 +426,11 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
| cannot_inline = dont_inline
| occurs_none = discard -- Note [discard during inlining]
| occurs_once = inline_and_discard
- | isTrivial dflags rhs = inline_and_keep
+ | isTrivial platform rhs = inline_and_keep
| otherwise = dont_inline
where
- platform = targetPlatform dflags
inline_and_discard = go usages' inl_node skipped rest
- where usages' = foldLocalRegsUsed dflags addUsage usages rhs
+ where usages' = foldLocalRegsUsed platform addUsage usages rhs
discard = go usages node skipped rest
@@ -443,7 +439,7 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
keep node' = (final_node, a : rest')
where (final_node, rest') = go usages' node' (insertLRegSet l skipped) rest
- usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2)
+ usages' = foldLocalRegsUsed platform (\m r -> addToUFM m r 2)
usages rhs
-- we must not inline anything that is mentioned in the RHS
-- of a binding that we have already skipped, so we set the
@@ -451,7 +447,7 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments]
|| l `elemLRegSet` skipped
- || not (okToInline dflags rhs node)
+ || not (okToInline platform rhs node)
l_usages = lookupUFM usages l
l_live = l `elemRegSet` live
@@ -569,25 +565,25 @@ regsUsedIn ls e = wrapRecExpf f e False
-- ought to be able to handle it properly, but currently neither PprC
-- nor the NCG can do it. See Note [Register parameter passing]
-- See also GHC.StgToCmm.Foreign.load_args_into_temps.
-okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
-okToInline dflags expr node@(CmmUnsafeForeignCall{}) =
- not (globalRegistersConflict dflags expr node)
+okToInline :: Platform -> CmmExpr -> CmmNode e x -> Bool
+okToInline platform expr node@(CmmUnsafeForeignCall{}) =
+ not (globalRegistersConflict platform expr node)
okToInline _ _ _ = True
-- -----------------------------------------------------------------------------
-- | @conflicts (r,e) node@ is @False@ if and only if the assignment
-- @r = e@ can be safely commuted past statement @node at .
-conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool
-conflicts dflags (r, rhs, addr) node
+conflicts :: Platform -> Assignment -> CmmNode O x -> Bool
+conflicts platform (r, rhs, addr) node
-- (1) node defines registers used by rhs of assignment. This catches
-- assignments and all three kinds of calls. See Note [Sinking and calls]
- | globalRegistersConflict dflags rhs node = True
- | localRegistersConflict dflags rhs node = True
+ | globalRegistersConflict platform rhs node = True
+ | localRegistersConflict platform rhs node = True
-- (2) node uses register defined by assignment
- | foldRegsUsed dflags (\b r' -> r == r' || b) False node = True
+ | foldRegsUsed platform (\b r' -> r == r' || b) False node = True
-- (3) a store to an address conflicts with a read of the same memory
| CmmStore addr' e <- node
@@ -606,21 +602,19 @@ conflicts dflags (r, rhs, addr) node
-- (7) otherwise, no conflict
| otherwise = False
- where
- platform = targetPlatform dflags
-- Returns True if node defines any global registers that are used in the
-- Cmm expression
-globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
-globalRegistersConflict dflags expr node =
- foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmGlobal r) expr)
+globalRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool
+globalRegistersConflict platform expr node =
+ foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmGlobal r) expr)
False node
-- Returns True if node defines any local registers that are used in the
-- Cmm expression
-localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
-localRegistersConflict dflags expr node =
- foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmLocal r) expr)
+localRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool
+localRegistersConflict platform expr node =
+ foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmLocal r) expr)
False node
-- Note [Sinking and calls]
=====================================
compiler/GHC/Cmm/Switch/Implement.hs
=====================================
@@ -6,6 +6,7 @@ where
import GHC.Prelude
+import GHC.Driver.Backend
import GHC.Platform
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.BlockId
@@ -13,7 +14,6 @@ import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.Types.Unique.Supply
-import GHC.Driver.Session
import GHC.Utils.Monad (concatMapM)
--
@@ -32,12 +32,12 @@ import GHC.Utils.Monad (concatMapM)
-- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for
-- code generation.
-cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph
-cmmImplementSwitchPlans dflags g
+cmmImplementSwitchPlans :: Backend -> Platform -> CmmGraph -> UniqSM CmmGraph
+cmmImplementSwitchPlans backend platform g
-- Switch generation done by backend (LLVM/C)
- | backendSupportsSwitch (backend dflags) = return g
+ | backendSupportsSwitch backend = return g
| otherwise = do
- blocks' <- concatMapM (visitSwitches (targetPlatform dflags)) (toBlockList g)
+ blocks' <- concatMapM (visitSwitches platform) (toBlockList g)
return $ ofBlockList (g_entry g) blocks'
visitSwitches :: Platform -> CmmBlock -> UniqSM [CmmBlock]
=====================================
compiler/GHC/CmmToC.hs
=====================================
@@ -91,7 +91,7 @@ pprTop platform = \case
blankLine,
extern_decls,
(if (externallyVisibleCLabel clbl)
- then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,
+ then mkFN_ else mkIF_) (pprCLabel_ViaC platform clbl) <+> lbrace,
nest 8 temp_decls,
vcat (map (pprBBlock platform) blocks),
rbrace ]
@@ -110,14 +110,14 @@ pprTop platform = \case
(CmmData section (CmmStaticsRaw lbl [CmmString str])) ->
pprExternDecl platform lbl $$
hcat [
- pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
+ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel_ViaC platform lbl,
text "[] = ", pprStringInCStyle str, semi
]
(CmmData section (CmmStaticsRaw lbl [CmmUninitialised size])) ->
pprExternDecl platform lbl $$
hcat [
- pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
+ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel_ViaC platform lbl,
brackets (int size), semi
]
@@ -153,7 +153,7 @@ pprWordArray platform is_ro lbl ds
= -- TODO: align closures only
pprExternDecl platform lbl $$
hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"
- , space, ppr lbl, text "[]"
+ , space, pprCLabel_ViaC platform lbl, text "[]"
-- See Note [StgWord alignment]
, pprAlignment (wordWidth platform)
, text "= {" ]
@@ -238,7 +238,7 @@ pprStmt platform stmt =
case fn of
CmmLit (CmmLabel lbl)
| StdCallConv <- cconv ->
- pprCall platform (ppr lbl) cconv hresults hargs
+ pprCall platform (pprCLabel_ViaC platform lbl) cconv hresults hargs
-- stdcall functions must be declared with
-- a function type, otherwise the C compiler
-- doesn't add the @n suffix to the label. We
@@ -247,7 +247,7 @@ pprStmt platform stmt =
| CmmNeverReturns <- ret ->
pprCall platform cast_fn cconv hresults hargs <> semi
| not (isMathFun lbl) ->
- pprForeignCall platform (ppr lbl) cconv hresults hargs
+ pprForeignCall platform (pprCLabel_ViaC platform lbl) cconv hresults hargs
_ ->
pprCall platform cast_fn cconv hresults hargs <> semi
-- for a dynamic call, no declaration is necessary.
@@ -487,7 +487,7 @@ pprLit platform lit = case lit of
-> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
where
- pprCLabelAddr lbl = char '&' <> ppr lbl
+ pprCLabelAddr lbl = char '&' <> pprCLabel_ViaC platform lbl
pprLit1 :: Platform -> CmmLit -> SDoc
pprLit1 platform lit = case lit of
@@ -1047,7 +1047,7 @@ pprExternDecl platform lbl
| not (needsCDecl lbl) = empty
| Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
| otherwise =
- hcat [ visibility, label_type lbl , lparen, ppr lbl, text ");"
+ hcat [ visibility, label_type lbl , lparen, pprCLabel_ViaC platform lbl, text ");"
-- occasionally useful to see label type
-- , text "/* ", pprDebugCLabel lbl, text " */"
]
@@ -1070,7 +1070,7 @@ pprExternDecl platform lbl
-- we must generate an appropriate prototype for it, so that the C compiler will
-- add the @n suffix to the label (#2276)
stdcall_decl sz =
- text "extern __attribute__((stdcall)) void " <> ppr lbl
+ text "extern __attribute__((stdcall)) void " <> pprCLabel_ViaC platform lbl
<> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform))))
<> semi
=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -51,8 +51,9 @@ module GHC.Core.DataCon (
splitDataProductType_maybe,
-- ** Predicates on DataCons
- isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
- isUnboxedSumCon,
+ isNullarySrcDataCon, isNullaryRepDataCon,
+ isTupleDataCon, isBoxedTupleDataCon, isUnboxedTupleDataCon,
+ isUnboxedSumDataCon,
isVanillaDataCon, classDataCon, dataConCannotMatch,
dataConUserTyVarsArePermuted,
isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,
@@ -1467,11 +1468,14 @@ dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat
isTupleDataCon :: DataCon -> Bool
isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc
-isUnboxedTupleCon :: DataCon -> Bool
-isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc
+isBoxedTupleDataCon :: DataCon -> Bool
+isBoxedTupleDataCon (MkData {dcRepTyCon = tc}) = isBoxedTupleTyCon tc
-isUnboxedSumCon :: DataCon -> Bool
-isUnboxedSumCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc
+isUnboxedTupleDataCon :: DataCon -> Bool
+isUnboxedTupleDataCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc
+
+isUnboxedSumDataCon :: DataCon -> Bool
+isUnboxedSumDataCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc
-- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors
isVanillaDataCon :: DataCon -> Bool
=====================================
compiler/GHC/Core/DataCon.hs-boot
=====================================
@@ -26,7 +26,7 @@ dataConInstOrigArgTys :: DataCon -> [Type] -> [Scaled Type]
dataConStupidTheta :: DataCon -> ThetaType
dataConFullSig :: DataCon
-> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type)
-isUnboxedSumCon :: DataCon -> Bool
+isUnboxedSumDataCon :: DataCon -> Bool
instance Eq DataCon
instance Uniquable DataCon
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -359,7 +359,7 @@ forcesRealWorld fam_envs ty
= True
| Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys }
<- deepSplitProductType_maybe fam_envs ty
- , isUnboxedTupleCon dc
+ , isUnboxedTupleDataCon dc
= any (\(ty,_) -> scaledThing ty `eqType` realWorldStatePrimTy) field_tys
| otherwise
= False
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -34,7 +34,7 @@ import GHC.Core.Coercion.Opt ( optCoercion )
import GHC.Core.FamInstEnv ( topNormaliseType_maybe )
import GHC.Core.DataCon
( DataCon, dataConWorkId, dataConRepStrictness
- , dataConRepArgTys, isUnboxedTupleCon
+ , dataConRepArgTys, isUnboxedTupleDataCon
, StrictnessMark (..) )
import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )
import GHC.Core
@@ -2957,7 +2957,7 @@ addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]
addEvals scrut con vs
-- Deal with seq# applications
| Just scr <- scrut
- , isUnboxedTupleCon con
+ , isUnboxedTupleDataCon con
, [s,x] <- vs
-- Use stripNArgs rather than collectArgsTicks to avoid building
-- a list of arguments only to throw it away immediately.
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -148,7 +148,7 @@ import {-# SOURCE #-} GHC.Builtin.Types
import {-# SOURCE #-} GHC.Core.DataCon
( DataCon, dataConExTyCoVars, dataConFieldLabels
, dataConTyCon, dataConFullSig
- , isUnboxedSumCon )
+ , isUnboxedSumDataCon )
import GHC.Builtin.Uniques
( tyConRepNameUnique
, dataConTyRepNameUnique )
@@ -1323,7 +1323,7 @@ tyConRepName_maybe (AlgTyCon { algTcParent = parent })
tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm })
= Just rep_nm
tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm })
- | isUnboxedSumCon dc -- see #13276
+ | isUnboxedSumDataCon dc -- see #13276
= Nothing
| otherwise
= Just rep_nm
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -889,7 +889,7 @@ conSize dc n_val_args
| n_val_args == 0 = SizeIs 0 emptyBag 10 -- Like variables
-- See Note [Unboxed tuple size and result discount]
- | isUnboxedTupleCon dc = SizeIs 0 emptyBag 10
+ | isUnboxedTupleDataCon dc = SizeIs 0 emptyBag 10
-- See Note [Constructor size and result discount]
| otherwise = SizeIs 10 emptyBag 10
=====================================
compiler/GHC/CoreToByteCode.hs
=====================================
@@ -648,7 +648,7 @@ schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
-- handle pairs with one void argument (e.g. state token)
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
- | isUnboxedTupleCon dc
+ | isUnboxedTupleDataCon dc
-- Convert
-- case .... of x { (# V'd-thing, a #) -> ... }
-- to
@@ -667,7 +667,7 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
-- handle unit tuples
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
- | isUnboxedTupleCon dc
+ | isUnboxedTupleDataCon dc
, typePrimRep (idType bndr) `lengthAtMost` 1
= doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
@@ -825,7 +825,7 @@ schemeT d s p app
-- Case 2: Constructor application
| Just con <- maybe_saturated_dcon
- , isUnboxedTupleCon con
+ , isUnboxedTupleDataCon con
= case args_r_to_l of
[arg1,arg2] | isVAtom arg1 ->
unboxedTupleReturn d s p arg2
@@ -1090,7 +1090,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
my_discr (DataAlt dc, _, _)
- | isUnboxedTupleCon dc || isUnboxedSumCon dc
+ | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc
= multiValException
| otherwise
= DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -188,7 +188,7 @@ toIfaceTypeX fr (TyConApp tc tys)
= IfaceTupleTy sort NotPromoted (toIfaceTcArgsX fr tc tys)
| Just dc <- isPromotedDataCon_maybe tc
- , isTupleDataCon dc
+ , isBoxedTupleDataCon dc
, n_tys == 2*arity
= IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys))
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -699,7 +699,7 @@ mkTopStgRhs dflags this_mod ccs bndr rhs
, -- Dynamic StgConApps are updatable
not (isDllConApp dflags this_mod con args)
= -- CorePrep does this right, but just to make sure
- ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con)
+ ASSERT2( not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)
, ppr bndr $$ ppr con $$ ppr args)
( StgRhsCon dontCareCCS con args, ccs )
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -83,7 +83,7 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
dflags
(text "CmmLint"<+>brackets (ppr this_mod))
(const ()) $ do
- { case cmmLint dflags cmm of
+ { case cmmLint (targetPlatform dflags) cmm of
Just err -> do { log_action dflags
dflags
NoReason
=====================================
compiler/GHC/HsToCore/PmCheck/Ppr.hs
=====================================
@@ -172,7 +172,7 @@ pprConLike delta _prec cl args
WcVarTerminated pref x ->
parens . fcat . punctuate colon <$> mapM (pprPmVar appPrec) (toList pref ++ [x])
pprConLike _delta _prec (RealDataCon con) args
- | isUnboxedTupleCon con
+ | isUnboxedTupleDataCon con
, let hash_parens doc = text "(#" <+> doc <+> text "#)"
= hash_parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args
| isTupleDataCon con
=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -164,7 +164,7 @@ lintStgRhs (StgRhsClosure _ _ _ binders expr)
lintStgExpr expr
lintStgRhs rhs@(StgRhsCon _ con args) = do
- when (isUnboxedTupleCon con || isUnboxedSumCon con) $ do
+ when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do
opts <- getStgPprOpts
addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
pprStgRhs opts rhs)
@@ -182,7 +182,7 @@ lintStgExpr (StgApp fun args) = do
lintStgExpr app@(StgConApp con args _arg_tys) = do
-- unboxed sums should vanish during unarise
lf <- getLintFlags
- when (lf_unarised lf && isUnboxedSumCon con) $ do
+ when (lf_unarised lf && isUnboxedSumDataCon con) $ do
opts <- getStgPprOpts
addErrL (text "Unboxed sum after unarise:" $$
pprStgExpr opts app)
=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -294,7 +294,7 @@ unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)
return (StgRhsClosure ext ccs update_flag args1 expr')
unariseRhs rho (StgRhsCon ccs con args)
- = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))
+ = ASSERT(not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
return (StgRhsCon ccs con (unariseConArgs rho args))
--------------------------------------------------------------------------------
@@ -372,10 +372,10 @@ unariseExpr rho (StgTick tick e)
-- Doesn't return void args.
unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]
unariseMulti_maybe rho dc args ty_args
- | isUnboxedTupleCon dc
+ | isUnboxedTupleDataCon dc
= Just (unariseConArgs rho args)
- | isUnboxedSumCon dc
+ | isUnboxedSumDataCon dc
, let args1 = ASSERT(isSingleton args) (unariseConArgs rho args)
= Just (mkUbxSum dc ty_args args1)
=====================================
compiler/GHC/StgToCmm/DataCon.hs
=====================================
@@ -354,7 +354,7 @@ bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
-- binders args, assuming that we have just returned from a 'case' which
-- found a con
bindConArgs (DataAlt con) base args
- = ASSERT(not (isUnboxedTupleCon con))
+ = ASSERT(not (isUnboxedTupleDataCon con))
do profile <- getProfile
platform <- getPlatform
let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args)
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -837,7 +837,7 @@ maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code =
cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind
cgConApp con stg_args
- | isUnboxedTupleCon con -- Unboxed tuple: assign and return
+ | isUnboxedTupleDataCon con -- Unboxed tuple: assign and return
= do { arg_exprs <- getNonVoidArgAmodes stg_args
; tickyUnboxedTupleReturn (length arg_exprs)
; emitReturn arg_exprs }
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -556,7 +556,7 @@ hasNoBinding :: Id -> Bool
hasNoBinding id = case Var.idDetails id of
PrimOpId _ -> True -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps
FCallId _ -> True
- DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc
+ DataConWorkId dc -> isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc
_ -> isCompulsoryUnfolding (idUnfolding id)
-- See Note [Levity-polymorphic Ids]
=====================================
testsuite/tests/ghci/scripts/T18644.script
=====================================
@@ -0,0 +1,3 @@
+:set -XDataKinds -XUnboxedTuples
+:kind! '(# #)
+:kind! '()
=====================================
testsuite/tests/ghci/scripts/T18644.stdout
=====================================
@@ -0,0 +1,4 @@
+'(# #) :: (# #)
+= '(# #)
+'() :: ()
+= '()
=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -315,3 +315,4 @@ test('T17403', normal, ghci_script, ['T17403.script'])
test('T17431', normal, ghci_script, ['T17431.script'])
test('T17549', normal, ghci_script, ['T17549.script'])
test('T17669', [extra_run_opts('-fexternal-interpreter -fobject-code'), expect_broken(17669)], ghci_script, ['T17669.script'])
+test('T18644', normal, ghci_script, ['T18644.script'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/04933454bfd0d4f7b23c9cecc845877d0f716468...ff8a6dead9e72d684d906346504ca0de30fa473a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/04933454bfd0d4f7b23c9cecc845877d0f716468...ff8a6dead9e72d684d906346504ca0de30fa473a
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/20200903/991958f3/attachment-0001.html>
More information about the ghc-commits
mailing list