Commit 048a9138 authored by Ben Gamari's avatar Ben Gamari 🐢

cmm: Use LocalBlockLabel instead of AsmTempLabel to represent blocks

blockLbl was originally changed in 8b007abb 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.
parent 17e71c14
...@@ -40,7 +40,7 @@ newBlockId :: MonadUnique m => m BlockId ...@@ -40,7 +40,7 @@ newBlockId :: MonadUnique m => m BlockId
newBlockId = mkBlockId <$> getUniqueM newBlockId = mkBlockId <$> getUniqueM
blockLbl :: BlockId -> CLabel blockLbl :: BlockId -> CLabel
blockLbl label = mkAsmTempLabel (getUnique label) blockLbl label = mkLocalBlockLabel (getUnique label)
infoTblLbl :: BlockId -> CLabel infoTblLbl :: BlockId -> CLabel
infoTblLbl label infoTblLbl label
......
module BlockId (BlockId, mkBlockId) where
import Hoopl.Label (Label)
import Unique (Unique)
type BlockId = Label
mkBlockId :: Unique -> BlockId
...@@ -25,6 +25,7 @@ module CLabel ( ...@@ -25,6 +25,7 @@ module CLabel (
mkClosureTableLabel, mkClosureTableLabel,
mkBytesLabel, mkBytesLabel,
mkLocalBlockLabel,
mkLocalClosureLabel, mkLocalClosureLabel,
mkLocalInfoTableLabel, mkLocalInfoTableLabel,
mkLocalClosureTableLabel, mkLocalClosureTableLabel,
...@@ -94,7 +95,7 @@ module CLabel ( ...@@ -94,7 +95,7 @@ module CLabel (
mkHpcTicksLabel, mkHpcTicksLabel,
hasCAF, hasCAF,
needsCDecl, maybeAsmTemp, externallyVisibleCLabel, needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,
isMathFun, isMathFun,
isCFunctionLabel, isGcPtrLabel, labelDynamic, isCFunctionLabel, isGcPtrLabel, labelDynamic,
...@@ -110,6 +111,7 @@ import GhcPrelude ...@@ -110,6 +111,7 @@ import GhcPrelude
import IdInfo import IdInfo
import BasicTypes import BasicTypes
import {-# SOURCE #-} BlockId (BlockId, mkBlockId)
import Packages import Packages
import Module import Module
import Name import Name
...@@ -170,6 +172,14 @@ data CLabel ...@@ -170,6 +172,14 @@ data CLabel
| RtsLabel | RtsLabel
RtsLabelInfo 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. -- | A 'C' (or otherwise foreign) label.
-- --
| ForeignLabel | ForeignLabel
...@@ -183,7 +193,6 @@ data CLabel ...@@ -183,7 +193,6 @@ data CLabel
FunctionOrData FunctionOrData
-- | A family of labels related to a particular case expression.
-- | Local temporary label used for native (or LLVM) code generation -- | Local temporary label used for native (or LLVM) code generation
| AsmTempLabel | AsmTempLabel
{-# UNPACK #-} !Unique {-# UNPACK #-} !Unique
...@@ -246,6 +255,7 @@ instance Ord CLabel where ...@@ -246,6 +255,7 @@ instance Ord CLabel where
compare b1 b2 `thenCmp` compare b1 b2 `thenCmp`
compare c1 c2 compare c1 c2
compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2 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 (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =
compare a1 a2 `thenCmp` compare a1 a2 `thenCmp`
compare b1 b2 `thenCmp` compare b1 b2 `thenCmp`
...@@ -281,6 +291,8 @@ instance Ord CLabel where ...@@ -281,6 +291,8 @@ instance Ord CLabel where
compare _ CmmLabel{} = GT compare _ CmmLabel{} = GT
compare RtsLabel{} _ = LT compare RtsLabel{} _ = LT
compare _ RtsLabel{} = GT compare _ RtsLabel{} = GT
compare LocalBlockLabel{} _ = LT
compare _ LocalBlockLabel{} = GT
compare ForeignLabel{} _ = LT compare ForeignLabel{} _ = LT
compare _ ForeignLabel{} = GT compare _ ForeignLabel{} = GT
compare AsmTempLabel{} _ = LT compare AsmTempLabel{} _ = LT
...@@ -495,6 +507,8 @@ mkCmmCodeLabel pkg str = CmmLabel pkg str CmmCode ...@@ -495,6 +507,8 @@ mkCmmCodeLabel pkg str = CmmLabel pkg str CmmCode
mkCmmDataLabel pkg str = CmmLabel pkg str CmmData mkCmmDataLabel pkg str = CmmLabel pkg str CmmData
mkCmmClosureLabel pkg str = CmmLabel pkg str CmmClosure mkCmmClosureLabel pkg str = CmmLabel pkg str CmmClosure
mkLocalBlockLabel :: Unique -> CLabel
mkLocalBlockLabel u = LocalBlockLabel u
-- Constructing RtsLabels -- Constructing RtsLabels
mkRtsPrimOpLabel :: PrimOp -> CLabel mkRtsPrimOpLabel :: PrimOp -> CLabel
...@@ -652,7 +666,7 @@ toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l) ...@@ -652,7 +666,7 @@ toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l)
toEntryLbl :: CLabel -> CLabel toEntryLbl :: CLabel -> CLabel
toEntryLbl (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry toEntryLbl (IdLabel n c LocalInfoTable) = IdLabel n c LocalEntry
toEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry 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]. -- See Note [Proc-point local block entry-point].
toEntryLbl (IdLabel n c _) = IdLabel n c Entry toEntryLbl (IdLabel n c _) = IdLabel n c Entry
toEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry toEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry
...@@ -710,6 +724,7 @@ needsCDecl (SRTLabel _) = True ...@@ -710,6 +724,7 @@ needsCDecl (SRTLabel _) = True
needsCDecl (LargeSRTLabel _) = False needsCDecl (LargeSRTLabel _) = False
needsCDecl (LargeBitmapLabel _) = False needsCDecl (LargeBitmapLabel _) = False
needsCDecl (IdLabel _ _ _) = True needsCDecl (IdLabel _ _ _) = True
needsCDecl (LocalBlockLabel _) = True
needsCDecl (StringLitLabel _) = False needsCDecl (StringLitLabel _) = False
needsCDecl (AsmTempLabel _) = False needsCDecl (AsmTempLabel _) = False
...@@ -732,11 +747,11 @@ needsCDecl (DynamicLinkerLabel {}) = panic "needsCDecl DynamicLinkerLabel" ...@@ -732,11 +747,11 @@ needsCDecl (DynamicLinkerLabel {}) = panic "needsCDecl DynamicLinkerLabel"
needsCDecl PicBaseLabel = panic "needsCDecl PicBaseLabel" needsCDecl PicBaseLabel = panic "needsCDecl PicBaseLabel"
needsCDecl (DeadStripPreventer {}) = panic "needsCDecl DeadStripPreventer" needsCDecl (DeadStripPreventer {}) = panic "needsCDecl DeadStripPreventer"
-- | If a label is a local temporary used for native code generation -- | If a label is a local block label then return just its 'BlockId', otherwise
-- then return just its unique, otherwise nothing. -- 'Nothing'.
maybeAsmTemp :: CLabel -> Maybe Unique maybeLocalBlockLabel :: CLabel -> Maybe BlockId
maybeAsmTemp (AsmTempLabel uq) = Just uq maybeLocalBlockLabel (LocalBlockLabel uq) = Just $ mkBlockId uq
maybeAsmTemp _ = Nothing maybeLocalBlockLabel _ = Nothing
-- | Check whether a label corresponds to a C function that has -- | Check whether a label corresponds to a C function that has
...@@ -843,6 +858,7 @@ externallyVisibleCLabel (StringLitLabel _) = False ...@@ -843,6 +858,7 @@ externallyVisibleCLabel (StringLitLabel _) = False
externallyVisibleCLabel (AsmTempLabel _) = False externallyVisibleCLabel (AsmTempLabel _) = False
externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False
externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (RtsLabel _) = True
externallyVisibleCLabel (LocalBlockLabel _) = False
externallyVisibleCLabel (CmmLabel _ _ _) = True externallyVisibleCLabel (CmmLabel _ _ _) = True
externallyVisibleCLabel (ForeignLabel{}) = True externallyVisibleCLabel (ForeignLabel{}) = True
externallyVisibleCLabel (IdLabel name _ info) = isExternalName name && externallyVisibleIdLabel info externallyVisibleCLabel (IdLabel name _ info) = isExternalName name && externallyVisibleIdLabel info
...@@ -953,6 +969,8 @@ labelDynamic dflags this_mod lbl = ...@@ -953,6 +969,8 @@ labelDynamic dflags this_mod lbl =
| otherwise -> | otherwise ->
True True
LocalBlockLabel _ -> False
ForeignLabel _ _ source _ -> ForeignLabel _ _ source _ ->
if os == OSMinGW32 if os == OSMinGW32
then case source of then case source of
...@@ -1069,6 +1087,13 @@ instance Outputable CLabel where ...@@ -1069,6 +1087,13 @@ instance Outputable CLabel where
pprCLabel :: Platform -> CLabel -> SDoc 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) pprCLabel platform (AsmTempLabel u)
| not (platformUnregisterised platform) | not (platformUnregisterised platform)
= getPprStyle $ \ sty -> = getPprStyle $ \ sty ->
...@@ -1080,8 +1105,9 @@ pprCLabel platform (AsmTempLabel u) ...@@ -1080,8 +1105,9 @@ pprCLabel platform (AsmTempLabel u)
pprCLabel platform (AsmTempDerivedLabel l suf) pprCLabel platform (AsmTempDerivedLabel l suf)
| cGhcWithNativeCodeGen == "YES" | cGhcWithNativeCodeGen == "YES"
= ptext (asmTempLabelPrefix platform) = ptext (asmTempLabelPrefix platform)
<> case l of AsmTempLabel u -> pprUniqueAlways u <> case l of AsmTempLabel u -> pprUniqueAlways u
_other -> pprCLabel platform l LocalBlockLabel u -> pprUniqueAlways u
_other -> pprCLabel platform l
<> ftext suf <> ftext suf
pprCLabel platform (DynamicLinkerLabel info lbl) pprCLabel platform (DynamicLinkerLabel info lbl)
...@@ -1138,6 +1164,8 @@ pprCLbl (CmmLabel _ str CmmCode) = ftext str ...@@ -1138,6 +1164,8 @@ pprCLbl (CmmLabel _ str CmmCode) = ftext str
pprCLbl (CmmLabel _ str CmmData) = ftext str pprCLbl (CmmLabel _ str CmmData) = ftext str
pprCLbl (CmmLabel _ str CmmPrimCall) = 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 (RtsApFast str)) = ftext str <> text "_fast"
pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset)) pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
......
...@@ -46,7 +46,7 @@ import TargetReg ...@@ -46,7 +46,7 @@ import TargetReg
import BlockId import BlockId
import Hoopl.Collections import Hoopl.Collections
import Hoopl.Label import Hoopl.Label
import CLabel ( CLabel, mkAsmTempLabel ) import CLabel ( CLabel )
import Debug import Debug
import FastString ( FastString ) import FastString ( FastString )
import UniqFM import UniqFM
...@@ -160,8 +160,7 @@ getBlockIdNat ...@@ -160,8 +160,7 @@ getBlockIdNat
getNewLabelNat :: NatM CLabel getNewLabelNat :: NatM CLabel
getNewLabelNat getNewLabelNat
= do u <- getUniqueNat = blockLbl <$> getBlockIdNat
return (mkAsmTempLabel u)
getNewRegNat :: Format -> NatM Reg getNewRegNat :: Format -> NatM Reg
......
...@@ -603,7 +603,7 @@ pprInstr (BCC cond blockid prediction) = hcat [ ...@@ -603,7 +603,7 @@ pprInstr (BCC cond blockid prediction) = hcat [
char '\t', char '\t',
ppr lbl ppr lbl
] ]
where lbl = mkAsmTempLabel (getUnique blockid) where lbl = mkLocalBlockLabel (getUnique blockid)
pprPrediction p = case p of pprPrediction p = case p of
Nothing -> empty Nothing -> empty
Just True -> char '+' Just True -> char '+'
...@@ -621,7 +621,7 @@ pprInstr (BCCFAR cond blockid prediction) = vcat [ ...@@ -621,7 +621,7 @@ pprInstr (BCCFAR cond blockid prediction) = vcat [
ppr lbl ppr lbl
] ]
] ]
where lbl = mkAsmTempLabel (getUnique blockid) where lbl = mkLocalBlockLabel (getUnique blockid)
neg_prediction = case prediction of neg_prediction = case prediction of
Nothing -> empty Nothing -> empty
Just True -> char '-' Just True -> char '-'
......
...@@ -51,8 +51,8 @@ shortcutStatics fn (Statics lbl statics) ...@@ -51,8 +51,8 @@ shortcutStatics fn (Statics lbl statics)
shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
shortcutLabel fn lab shortcutLabel fn lab
| Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId
| otherwise = lab | otherwise = lab
shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
shortcutStatic fn (CmmStaticLit (CmmLabel lab)) shortcutStatic fn (CmmStaticLit (CmmLabel lab))
...@@ -71,6 +71,6 @@ shortBlockId ...@@ -71,6 +71,6 @@ shortBlockId
shortBlockId fn blockid = shortBlockId fn blockid =
case fn blockid of case fn blockid of
Nothing -> mkAsmTempLabel uq Nothing -> mkLocalBlockLabel uq
Just (DestBlockId blockid') -> shortBlockId fn blockid' Just (DestBlockId blockid') -> shortBlockId fn blockid'
where uq = getUnique blockid where uq = getUnique blockid
...@@ -46,8 +46,8 @@ shortcutStatics fn (Statics lbl statics) ...@@ -46,8 +46,8 @@ shortcutStatics fn (Statics lbl statics)
shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
shortcutLabel fn lab shortcutLabel fn lab
| Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId
| otherwise = lab | otherwise = lab
shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
shortcutStatic fn (CmmStaticLit (CmmLabel lab)) shortcutStatic fn (CmmStaticLit (CmmLabel lab))
......
...@@ -1035,8 +1035,8 @@ shortcutStatics fn (align, Statics lbl statics) ...@@ -1035,8 +1035,8 @@ shortcutStatics fn (align, Statics lbl statics)
shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
shortcutLabel fn lab shortcutLabel fn lab
| Just uq <- maybeAsmTemp lab = shortBlockId fn emptyUniqSet (mkBlockId uq) | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn emptyUniqSet blkId
| otherwise = lab | otherwise = lab
shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
shortcutStatic fn (CmmStaticLit (CmmLabel lab)) shortcutStatic fn (CmmStaticLit (CmmLabel lab))
...@@ -1056,8 +1056,8 @@ shortBlockId ...@@ -1056,8 +1056,8 @@ shortBlockId
shortBlockId fn seen blockid = shortBlockId fn seen blockid =
case (elementOfUniqSet uq seen, fn blockid) of case (elementOfUniqSet uq seen, fn blockid) of
(True, _) -> mkAsmTempLabel uq (True, _) -> blockLbl blockid
(_, Nothing) -> mkAsmTempLabel uq (_, Nothing) -> blockLbl blockid
(_, Just (DestBlockId blockid')) -> shortBlockId fn (addOneToUniqSet seen uq) blockid' (_, Just (DestBlockId blockid')) -> shortBlockId fn (addOneToUniqSet seen uq) blockid'
(_, Just (DestImm (ImmCLbl lbl))) -> lbl (_, Just (DestImm (ImmCLbl lbl))) -> lbl
(_, _other) -> panic "shortBlockId" (_, _other) -> panic "shortBlockId"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment