[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