cmm: Use LocalBlockLabel instead of AsmTempLabel to represent blocks

blockLbl was originally changed in 8b007abbeb3045900a11529d907a835080129176 to
use mkTempAsmLabel to fix an inconsistency resulting in #14221. However, this
breaks the C code generator, which doesn't support AsmTempLabels (#14454).

Instead let's try going the other direction: use a new CLabel variety,
LocalBlockLabel. Then we can teach the C code generator to deal with
these as well.

8 files changed, 60 insertions, 25 deletions

diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs
index d2e0161d69..73de69efcf 100644
--- a/compiler/cmm/BlockId.hs
+++ b/compiler/cmm/BlockId.hs
@@ -40,7 +40,7 @@ newBlockId :: MonadUnique m => m BlockId
 newBlockId = mkBlockId <$> getUniqueM
 
 blockLbl :: BlockId -> CLabel
-blockLbl label = mkAsmTempLabel (getUnique label)
+blockLbl label = mkLocalBlockLabel (getUnique label)
 
 infoTblLbl :: BlockId -> CLabel
 infoTblLbl label
diff --git a/compiler/cmm/BlockId.hs-boot b/compiler/cmm/BlockId.hs-boot
new file mode 100644
index 0000000000..3ad4141184
--- /dev/null
+++ b/compiler/cmm/BlockId.hs-boot
@@ -0,0 +1,8 @@
+module BlockId (BlockId, mkBlockId) where
+
+import Hoopl.Label (Label)
+import Unique (Unique)
+
+type BlockId = Label
+
+mkBlockId :: Unique -> BlockId
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index bb49d87a6f..9eb5ce6c84 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -25,6 +25,7 @@ module CLabel (
         mkClosureTableLabel,
         mkBytesLabel,
 
+        mkLocalBlockLabel,
         mkLocalClosureLabel,
         mkLocalInfoTableLabel,
         mkLocalClosureTableLabel,
@@ -94,7 +95,7 @@ module CLabel (
         mkHpcTicksLabel,
 
         hasCAF,
-        needsCDecl, maybeAsmTemp, externallyVisibleCLabel,
+        needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,
         isMathFun,
         isCFunctionLabel, isGcPtrLabel, labelDynamic,
 
@@ -110,6 +111,7 @@ import GhcPrelude
 
 import IdInfo
 import BasicTypes
+import {-# SOURCE #-} BlockId (BlockId, mkBlockId)
 import Packages
 import Module
 import Name
@@ -170,6 +172,14 @@ data CLabel
   | RtsLabel
         RtsLabelInfo
 
+  -- | A label associated with a block. These aren't visible outside of the
+  -- compilation unit in which they are defined. These are generally used to
+  -- name blocks produced by Cmm-to-Cmm passes and the native code generator,
+  -- where we don't have a 'Name' to associate the label to and therefore can't
+  -- use 'IdLabel'.
+  | LocalBlockLabel
+        {-# UNPACK #-} !Unique
+
   -- | A 'C' (or otherwise foreign) label.
   --
   | ForeignLabel
@@ -183,7 +193,6 @@ data CLabel
 
         FunctionOrData
 
-  -- | A family of labels related to a particular case expression.
   -- | Local temporary label used for native (or LLVM) code generation
   | AsmTempLabel
         {-# UNPACK #-} !Unique
@@ -246,6 +255,7 @@ instance Ord CLabel where
     compare b1 b2 `thenCmp`
     compare c1 c2
   compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2
+  compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2
   compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =
     compare a1 a2 `thenCmp`
     compare b1 b2 `thenCmp`
@@ -281,6 +291,8 @@ instance Ord CLabel where
   compare _ CmmLabel{} = GT
   compare RtsLabel{} _ = LT
   compare _ RtsLabel{} = GT
+  compare LocalBlockLabel{} _ = LT
+  compare _ LocalBlockLabel{} = GT
   compare ForeignLabel{} _ = LT
   compare _ ForeignLabel{} = GT
   compare AsmTempLabel{} _ = LT
@@ -495,6 +507,8 @@ mkCmmCodeLabel      pkg str     = CmmLabel pkg str CmmCode
 mkCmmDataLabel      pkg str     = CmmLabel pkg str CmmData
 mkCmmClosureLabel   pkg str     = CmmLabel pkg str CmmClosure
 
+mkLocalBlockLabel :: Unique -> CLabel
+mkLocalBlockLabel u = LocalBlockLabel u
 
 -- Constructing RtsLabels
 mkRtsPrimOpLabel :: PrimOp -> CLabel
@@ -652,7 +666,7 @@ toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l)
 toEntryLbl :: CLabel -> CLabel
 toEntryLbl (IdLabel n c LocalInfoTable)  = IdLabel n c LocalEntry
 toEntryLbl (IdLabel n c ConInfoTable)    = IdLabel n c ConEntry
-toEntryLbl (IdLabel n _ BlockInfoTable)  = mkAsmTempLabel (nameUnique n)
+toEntryLbl (IdLabel n _ BlockInfoTable)  = mkLocalBlockLabel (nameUnique n)
                               -- See Note [Proc-point local block entry-point].
 toEntryLbl (IdLabel n c _)               = IdLabel n c Entry
 toEntryLbl (CmmLabel m str CmmInfo)      = CmmLabel m str CmmEntry
@@ -710,6 +724,7 @@ needsCDecl (SRTLabel _)                 = True
 needsCDecl (LargeSRTLabel _)            = False
 needsCDecl (LargeBitmapLabel _)         = False
 needsCDecl (IdLabel _ _ _)              = True
+needsCDecl (LocalBlockLabel _)          = True
 
 needsCDecl (StringLitLabel _)           = False
 needsCDecl (AsmTempLabel _)             = False
@@ -732,11 +747,11 @@ needsCDecl (DynamicLinkerLabel {})      = panic "needsCDecl DynamicLinkerLabel"
 needsCDecl PicBaseLabel                 = panic "needsCDecl PicBaseLabel"
 needsCDecl (DeadStripPreventer {})      = panic "needsCDecl DeadStripPreventer"
 
--- | If a label is a local temporary used for native code generation
---      then return just its unique, otherwise nothing.
-maybeAsmTemp :: CLabel -> Maybe Unique
-maybeAsmTemp (AsmTempLabel uq)          = Just uq
-maybeAsmTemp _                          = Nothing
+-- | If a label is a local block label then return just its 'BlockId', otherwise
+-- 'Nothing'.
+maybeLocalBlockLabel :: CLabel -> Maybe BlockId
+maybeLocalBlockLabel (LocalBlockLabel uq)  = Just $ mkBlockId uq
+maybeLocalBlockLabel _                     = Nothing
 
 
 -- | Check whether a label corresponds to a C function that has
@@ -843,6 +858,7 @@ externallyVisibleCLabel (StringLitLabel _)      = False
 externallyVisibleCLabel (AsmTempLabel _)        = False
 externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False
 externallyVisibleCLabel (RtsLabel _)            = True
+externallyVisibleCLabel (LocalBlockLabel _)     = False
 externallyVisibleCLabel (CmmLabel _ _ _)        = True
 externallyVisibleCLabel (ForeignLabel{})        = True
 externallyVisibleCLabel (IdLabel name _ info)   = isExternalName name && externallyVisibleIdLabel info
@@ -953,6 +969,8 @@ labelDynamic dflags this_mod lbl =
     | otherwise ->
        True
 
+   LocalBlockLabel _    -> False
+
    ForeignLabel _ _ source _  ->
        if os == OSMinGW32
        then case source of
@@ -1069,6 +1087,13 @@ instance Outputable CLabel where
 
 pprCLabel :: Platform -> CLabel -> SDoc
 
+pprCLabel platform (LocalBlockLabel u)
+  =  getPprStyle $ \ sty ->
+     if asmStyle sty then
+        ptext (asmTempLabelPrefix platform) <> pprUniqueAlways u
+     else
+        char '_' <> pprUniqueAlways u
+
 pprCLabel platform (AsmTempLabel u)
  | not (platformUnregisterised platform)
   =  getPprStyle $ \ sty ->
@@ -1080,8 +1105,9 @@ pprCLabel platform (AsmTempLabel u)
 pprCLabel platform (AsmTempDerivedLabel l suf)
  | cGhcWithNativeCodeGen == "YES"
    = ptext (asmTempLabelPrefix platform)
-     <> case l of AsmTempLabel u -> pprUniqueAlways u
-                  _other         -> pprCLabel platform l
+     <> case l of AsmTempLabel u    -> pprUniqueAlways u
+                  LocalBlockLabel u -> pprUniqueAlways u
+                  _other            -> pprCLabel platform l
      <> ftext suf
 
 pprCLabel platform (DynamicLinkerLabel info lbl)
@@ -1138,6 +1164,8 @@ pprCLbl (CmmLabel _ str CmmCode)        = ftext str
 pprCLbl (CmmLabel _ str CmmData)        = ftext str
 pprCLbl (CmmLabel _ str CmmPrimCall)    = ftext str
 
+pprCLbl (LocalBlockLabel u)             = text "blk_" <> pprUniqueAlways u
+
 pprCLbl (RtsLabel (RtsApFast str))   = ftext str <> text "_fast"
 
 pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs
index f4d02dae3c..b9532e17b5 100644
--- a/compiler/nativeGen/NCGMonad.hs
+++ b/compiler/nativeGen/NCGMonad.hs
@@ -46,7 +46,7 @@ import TargetReg
 import BlockId
 import Hoopl.Collections
 import Hoopl.Label
-import CLabel           ( CLabel, mkAsmTempLabel )
+import CLabel           ( CLabel )
 import Debug
 import FastString       ( FastString )
 import UniqFM
@@ -160,8 +160,7 @@ getBlockIdNat
 
 getNewLabelNat :: NatM CLabel
 getNewLabelNat
- = do   u <- getUniqueNat
-        return (mkAsmTempLabel u)
+ = blockLbl <$> getBlockIdNat
 
 
 getNewRegNat :: Format -> NatM Reg
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 101628e3a3..2f64d82ee5 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -603,7 +603,7 @@ pprInstr (BCC cond blockid prediction) = hcat [
         char '\t',
         ppr lbl
     ]
-    where lbl = mkAsmTempLabel (getUnique blockid)
+    where lbl = mkLocalBlockLabel (getUnique blockid)
           pprPrediction p = case p of
             Nothing    -> empty
             Just True  -> char '+'
@@ -621,7 +621,7 @@ pprInstr (BCCFAR cond blockid prediction) = vcat [
             ppr lbl
         ]
     ]
-    where lbl = mkAsmTempLabel (getUnique blockid)
+    where lbl = mkLocalBlockLabel (getUnique blockid)
           neg_prediction = case prediction of
             Nothing    -> empty
             Just True  -> char '-'
diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs
index bf894fd42f..1015ed661d 100644
--- a/compiler/nativeGen/PPC/RegInfo.hs
+++ b/compiler/nativeGen/PPC/RegInfo.hs
@@ -51,8 +51,8 @@ shortcutStatics fn (Statics lbl statics)
 
 shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
 shortcutLabel fn lab
-  | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq)
-  | otherwise                   = lab
+  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId
+  | otherwise                              = lab
 
 shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
 shortcutStatic fn (CmmStaticLit (CmmLabel lab))
@@ -71,6 +71,6 @@ shortBlockId
 
 shortBlockId fn blockid =
    case fn blockid of
-      Nothing -> mkAsmTempLabel uq
+      Nothing -> mkLocalBlockLabel uq
       Just (DestBlockId blockid')  -> shortBlockId fn blockid'
    where uq = getUnique blockid
diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs
index 0df280095b..86c28138f1 100644
--- a/compiler/nativeGen/SPARC/ShortcutJump.hs
+++ b/compiler/nativeGen/SPARC/ShortcutJump.hs
@@ -46,8 +46,8 @@ shortcutStatics fn (Statics lbl statics)
 
 shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
 shortcutLabel fn lab
-  | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq)
-  | otherwise                   = lab
+  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId
+  | otherwise                              = lab
 
 shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
 shortcutStatic fn (CmmStaticLit (CmmLabel lab))
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index 1bb682ad87..c937d4dba0 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -1035,8 +1035,8 @@ shortcutStatics fn (align, Statics lbl statics)
 
 shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
 shortcutLabel fn lab
-  | Just uq <- maybeAsmTemp lab = shortBlockId fn emptyUniqSet (mkBlockId uq)
-  | otherwise                   = lab
+  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn emptyUniqSet blkId
+  | otherwise                              = lab
 
 shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
 shortcutStatic fn (CmmStaticLit (CmmLabel lab))
@@ -1056,8 +1056,8 @@ shortBlockId
 
 shortBlockId fn seen blockid =
   case (elementOfUniqSet uq seen, fn blockid) of
-    (True, _)    -> mkAsmTempLabel uq
-    (_, Nothing) -> mkAsmTempLabel uq
+    (True, _)    -> blockLbl blockid
+    (_, Nothing) -> blockLbl blockid
     (_, Just (DestBlockId blockid'))  -> shortBlockId fn (addOneToUniqSet seen uq) blockid'
     (_, Just (DestImm (ImmCLbl lbl))) -> lbl
     (_, _other) -> panic "shortBlockId"