[Git][ghc/ghc][wip/romes/12935] Progress
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Fri May 24 16:04:36 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/12935 at Glasgow Haskell Compiler / GHC
Commits:
e3f37027 by Rodrigo Mesquita at 2024-05-24T17:03:59+01:00
Progress
- - - - -
4 changed files:
- compiler/GHC/Cmm/BlockId.hs
- compiler/GHC/Cmm/Switch.hs
- compiler/GHC/Cmm/UniqueRenamer.hs
- compiler/GHC/Driver/CodeOutput.hs
Changes:
=====================================
compiler/GHC/Cmm/BlockId.hs
=====================================
@@ -45,3 +45,4 @@ blockLbl label = mkLocalBlockLabel (getUnique label)
infoTblLbl :: BlockId -> CLabel
infoTblLbl label
= mkBlockInfoTableLabel (mkFCallName (getUnique label) (fsLit "block")) NoCafRefs
+
=====================================
compiler/GHC/Cmm/Switch.hs
=====================================
@@ -4,7 +4,7 @@ module GHC.Cmm.Switch (
SwitchTargets,
mkSwitchTargets,
switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned,
- mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough,
+ mapSwitchTargets, mapSwitchTargetsA, switchTargetsToTable, switchTargetsFallThrough,
switchTargetsToList, eqSwitchTargetWith,
SwitchPlan(..),
@@ -136,6 +136,11 @@ mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets
mapSwitchTargets f (SwitchTargets signed range mbdef branches)
= SwitchTargets signed range (fmap f mbdef) (fmap f branches)
+-- | Changes all labels mentioned in the SwitchTargets value
+mapSwitchTargetsA :: Applicative m => (Label -> m Label) -> SwitchTargets -> m SwitchTargets
+mapSwitchTargetsA f (SwitchTargets signed range mbdef branches)
+ = SwitchTargets signed range <$> traverse f mbdef <*> traverse f branches
+
-- | Returns the list of non-default branches of the SwitchTargets value
switchTargetsCases :: SwitchTargets -> [(Integer, Label)]
switchTargetsCases (SwitchTargets _ _ _ branches) = M.toList branches
=====================================
compiler/GHC/Cmm/UniqueRenamer.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, UnicodeSyntax #-}
module GHC.Cmm.UniqueRenamer
( detRenameUniques
@@ -14,8 +14,10 @@ import GHC.Cmm.CLabel
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
+import GHC.Cmm.Switch
import GHC.Types.Unique
import GHC.Types.Unique.FM
+import GHC.Utils.Outputable as Outputable
import Data.Tuple (swap)
{-
@@ -39,6 +41,11 @@ data DetUniqFM = DetUniqFM
, supply :: !Word64
}
+instance Outputable DetUniqFM where
+ ppr DetUniqFM{mapping, supply} =
+ ppr mapping $$
+ text "supply:" Outputable.<> ppr supply
+
type DetRnM = State DetUniqFM
emptyDetUFM :: DetUniqFM
@@ -77,6 +84,9 @@ detRenameCLabel = mapInternalNonDetUniques renameDetUniq
class UniqRenamable a where
uniqRename :: a -> DetRnM a
+instance UniqRenamable Unique where
+ uniqRename = renameDetUniq
+
instance UniqRenamable CLabel where
-- The most important renaming. The rest are just traversals.
uniqRename = detRenameCLabel
@@ -84,6 +94,9 @@ instance UniqRenamable CLabel where
instance UniqRenamable LocalReg where
uniqRename (LocalReg uq t) = LocalReg <$> renameDetUniq uq <*> pure t
+instance UniqRenamable Label where
+ uniqRename lbl = mkHooplLabel . getKey <$> renameDetUniq (getUnique lbl)
+
instance UniqRenamable CmmTickScope where
-- ROMES:TODO: We may have to change this to get deterministic objects with ticks.
uniqRename = pure
@@ -119,15 +132,16 @@ instance UniqRenamable CmmLit where
CmmLabelOff lbl i -> CmmLabelOff <$> uniqRename lbl <*> pure i
CmmLabelDiffOff lbl1 lbl2 i w ->
CmmLabelDiffOff <$> uniqRename lbl1 <*> uniqRename lbl2 <*> pure i <*> pure w
- CmmBlock bid -> pure $ CmmBlock bid
+ CmmBlock bid -> CmmBlock <$> uniqRename bid
CmmHighStackMark -> pure CmmHighStackMark
instance UniqRenamable a {- for 'Body' and on 'RawCmmStatics' -}
=> UniqRenamable (LabelMap a) where
- uniqRename = traverse uniqRename
+ -- ROMES:TODO: Can a rename of the map have collisions and we lose values? Think harder...
+ uniqRename lm = mapFromList <$> traverse (\(l,x) -> (,) <$> uniqRename l <*> uniqRename x) (mapToList lm)
instance UniqRenamable CmmGraph where
- uniqRename (CmmGraph e g) = CmmGraph e <$> uniqRename g
+ uniqRename (CmmGraph e g) = CmmGraph <$> uniqRename e <*> uniqRename g
instance UniqRenamable (Graph CmmNode n m) where
uniqRename = \case
@@ -153,7 +167,7 @@ instance UniqRenamable (Block CmmNode n m) where
instance UniqRenamable (CmmNode n m) where
uniqRename = \case
- CmmEntry l t -> CmmEntry l <$> uniqRename t
+ CmmEntry l t -> CmmEntry <$> uniqRename l <*> uniqRename t
CmmComment fs -> pure $ CmmComment fs
CmmTick tickish -> pure $ CmmTick tickish
CmmUnwind xs -> CmmUnwind <$> mapM uniqRename xs
@@ -161,16 +175,16 @@ instance UniqRenamable (CmmNode n m) where
CmmStore e1 e2 align -> CmmStore <$> uniqRename e1 <*> uniqRename e2 <*> pure align
CmmUnsafeForeignCall ftgt cmmformal cmmactual ->
CmmUnsafeForeignCall <$> uniqRename ftgt <*> mapM uniqRename cmmformal <*> mapM uniqRename cmmactual
- CmmBranch l -> pure $ CmmBranch l
+ CmmBranch l -> CmmBranch <$> uniqRename l
CmmCondBranch pred t f likely ->
- CmmCondBranch <$> uniqRename pred <*> pure t <*> pure f <*> pure likely
- CmmSwitch e sts -> CmmSwitch <$> uniqRename e <*> pure sts
+ CmmCondBranch <$> uniqRename pred <*> uniqRename t <*> uniqRename f <*> pure likely
+ CmmSwitch e sts -> CmmSwitch <$> uniqRename e <*> mapSwitchTargetsA uniqRename sts
CmmCall tgt cont regs args retargs retoff ->
- CmmCall <$> uniqRename tgt <*> pure cont <*> mapM uniqRename regs
+ CmmCall <$> uniqRename tgt <*> uniqRename cont <*> mapM uniqRename regs
<*> pure args <*> pure retargs <*> pure retoff
CmmForeignCall tgt res args succ retargs retoff intrbl ->
CmmForeignCall <$> uniqRename tgt <*> mapM uniqRename res <*> mapM uniqRename args
- <*> pure succ <*> pure retargs <*> pure retoff <*> pure intrbl
+ <*> uniqRename succ <*> pure retargs <*> pure retoff <*> pure intrbl
instance UniqRenamable GlobalReg where
uniqRename = pure
@@ -181,9 +195,13 @@ instance UniqRenamable CmmExpr where
CmmLoad e t a -> CmmLoad <$> uniqRename e <*> pure t <*> pure a
CmmReg r -> CmmReg <$> uniqRename r
CmmMachOp mop es -> CmmMachOp mop <$> mapM uniqRename es
- CmmStackSlot a i -> pure $ CmmStackSlot a i
+ CmmStackSlot a i -> CmmStackSlot <$> uniqRename a <*> pure i
CmmRegOff r i -> CmmRegOff <$> uniqRename r <*> pure i
+instance UniqRenamable Area where
+ uniqRename Old = pure Old
+ uniqRename (Young l) = Young <$> uniqRename l
+
instance UniqRenamable ForeignTarget where
uniqRename = \case
ForeignTarget e fc -> ForeignTarget <$> uniqRename e <*> pure fc
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -100,10 +100,12 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g
-- For example, the fix-up action in the ASM NCG should use determinist names for potential new blocks it has to create.
-- Therefore, in the ASM NCG `NatM` Monad we use a deterministic `UniqSuply` (which won't be shared about multiple threads)
-- TODO: Put these all into notes carefully organized
- ; let renamed_cmm_stream =
+ ; let renamed_cmm_stream = do
-- if gopt Opt_DeterministicObjects dflags
- snd <$> Stream.mapAccumL_ (fmap pure . detRenameUniques) emptyDetUFM cmm_stream
+ (rn_mapping, stream) <- Stream.mapAccumL_ (fmap pure . detRenameUniques) emptyDetUFM cmm_stream
+ Stream.liftIO $ debugTraceMsg logger 3 (text "DetRnM mapping:" <+> ppr rn_mapping)
+ return stream
-- Lint each CmmGroup as it goes past
; let linted_cmm_stream =
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3f3702779f6e754130751580cdd768c64f18ba0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3f3702779f6e754130751580cdd768c64f18ba0
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/20240524/fa9225e8/attachment-0001.html>
More information about the ghc-commits
mailing list