[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