[Git][ghc/ghc][wip/romes/12935] 2 commits: Disable local test on CI

Rodrigo Mesquita (@alt-romes) gitlab at gitlab.haskell.org
Fri May 24 14:33:32 UTC 2024



Rodrigo Mesquita pushed to branch wip/romes/12935 at Glasgow Haskell Compiler / GHC


Commits:
555cd242 by Rodrigo Mesquita at 2024-05-24T15:33:21+01:00
Disable local test on CI

- - - - -
299bb838 by Rodrigo Mesquita at 2024-05-24T15:33:21+01:00
WIP

- - - - -


7 changed files:

- compiler/GHC/Cmm/CLabel.hs
- + compiler/GHC/Cmm/UniqueRenamer.hs
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Types/Unique.hs
- compiler/ghc.cabal.in
- testsuite/tests/determinism/object/all.T


Changes:

=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 -----------------------------------------------------------------------------
 --
 -- Object-file symbols (called CLabel for historical reasons).
@@ -134,7 +135,8 @@ module GHC.Cmm.CLabel (
         -- * Others
         dynamicLinkerLabelInfo,
         addLabelSize,
-        foreignLabelStdcallInfo
+        foreignLabelStdcallInfo,
+        mapInternalNonDetUniques
     ) where
 
 import GHC.Prelude
@@ -1878,3 +1880,37 @@ The transformation is performed because
      T15155.a_closure `mayRedirectTo` a1_rXq_closure+1
 returns True.
 -}
+
+-- | A utility for renaming uniques in CLabels to produce deterministic object.
+-- Note that not all Uniques are mapped over. Only those that can be safely alpha
+-- renamed, eg uniques of local symbols or of system names.
+-- See Note [....TODO]
+mapInternalNonDetUniques :: Applicative m => (Unique -> m Unique) -> CLabel -> m CLabel
+mapInternalNonDetUniques f = \case
+  il@(IdLabel name cafInfo idLabelInfo)
+    | isInternalName name
+    -> IdLabel . setNameUnique name <$> f (nameUnique name) <*> pure cafInfo <*> pure idLabelInfo
+    | otherwise
+    -> pure il
+  cl at CmmLabel{} -> pure cl
+  -- ROMES:TODO: what about `RtsApFast NonDetFastString`?
+  RtsLabel rtsLblInfo -> pure $ RtsLabel rtsLblInfo
+  LocalBlockLabel unique -> LocalBlockLabel <$> f unique
+  fl at ForeignLabel{} -> pure fl 
+  AsmTempLabel unique -> AsmTempLabel <$> f unique
+  AsmTempDerivedLabel clbl fs -> AsmTempDerivedLabel <$> mapInternalNonDetUniques f clbl <*> pure fs
+  StringLitLabel unique -> StringLitLabel <$> f unique
+  CC_Label  cc -> pure $ CC_Label cc
+  CCS_Label ccs -> pure $ CCS_Label ccs
+  IPE_Label ipe at InfoProvEnt{infoTablePtr} ->
+    (\cl' -> IPE_Label ipe{infoTablePtr = cl'}) <$> mapInternalNonDetUniques f infoTablePtr
+  ml at ModuleLabel{} -> pure ml
+  -- ROMES:TODO: Suspicious, maybe we shouldn't rename these.
+  DynamicLinkerLabel dlli clbl -> DynamicLinkerLabel dlli <$> mapInternalNonDetUniques f clbl
+  PicBaseLabel -> pure PicBaseLabel
+  DeadStripPreventer clbl -> DeadStripPreventer <$> mapInternalNonDetUniques f clbl
+  HpcTicksLabel mod -> pure $ HpcTicksLabel mod
+  SRTLabel unique -> SRTLabel <$> f unique
+  LargeBitmapLabel unique -> LargeBitmapLabel <$> f unique
+
+


=====================================
compiler/GHC/Cmm/UniqueRenamer.hs
=====================================
@@ -0,0 +1,202 @@
+{-# LANGUAGE LambdaCase #-}
+module GHC.Cmm.UniqueRenamer
+  ( detRenameUniques
+
+  -- Careful! Not for general use!
+  , DetUniqFM, emptyDetUFM)
+  where
+
+import Prelude
+import Control.Monad.Trans.State
+import GHC.Word
+import GHC.Cmm
+import GHC.Cmm.CLabel
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Label
+import GHC.Types.Unique
+import GHC.Types.Unique.FM
+import Data.Tuple (swap)
+
+{-
+--------------------------------------------------------------------------------
+-- * Deterministic Objects
+--------------------------------------------------------------------------------
+
+** Write many notes in a collective note.
+
+Topics:
+* Before generating Code, we rename all uniques of local symbols deterministically
+* The code generation (like Assembly fix ups) need
+
+-}
+
+-- | A mapping from non-deterministic uniques to deterministic uniques, to
+-- rename local symbols with the end goal of producing deterministic object files.
+-- See Note [....TODO]
+data DetUniqFM = DetUniqFM
+  { mapping :: UniqFM Unique Unique
+  , supply :: !Word64
+  }
+
+type DetRnM = State DetUniqFM
+
+emptyDetUFM :: DetUniqFM
+emptyDetUFM = DetUniqFM { mapping = emptyUFM, supply = 1 }
+
+renameDetUniq :: Unique -> DetRnM Unique
+renameDetUniq uq = do
+  m <- gets mapping
+  case lookupUFM m uq of
+    Nothing -> do
+      new_w <- gets supply -- New deterministic unique in this `DetRnM`
+      let (tag, _) = unpkUnique uq
+          det_uniq = mkUnique tag new_w
+      modify' (\DetUniqFM{mapping, supply} ->
+        -- Update supply and mapping
+        DetUniqFM{mapping = addToUFM mapping uq det_uniq, supply = supply + 1})
+      return det_uniq
+    Just det_uniq ->
+      return det_uniq
+
+-- Rename local symbols deterministically (in order of appearance)
+detRenameUniques :: DetUniqFM -> RawCmmGroup -> (DetUniqFM, RawCmmGroup)
+detRenameUniques dufm group = swap $ runState (mapM uniqRename group) dufm
+
+-- The most important function here, which does the actual renaming.
+-- Arguably, maybe we should rename this to CLabelRenamer
+detRenameCLabel :: CLabel -> DetRnM CLabel
+detRenameCLabel = mapInternalNonDetUniques renameDetUniq
+
+--------------------------------------------------------------------------------
+-- Traversals
+--------------------------------------------------------------------------------
+-- I think I should be able to implement this using some generic traversal,
+-- which would be cleaner
+
+class UniqRenamable a where
+  uniqRename :: a -> DetRnM a
+
+instance UniqRenamable CLabel where
+  -- The most important renaming. The rest are just traversals.
+  uniqRename = detRenameCLabel
+
+instance UniqRenamable LocalReg where
+  uniqRename (LocalReg uq t) = LocalReg <$> renameDetUniq uq <*> pure t
+
+instance UniqRenamable CmmTickScope where
+  -- ROMES:TODO: We may have to change this to get deterministic objects with ticks.
+  uniqRename = pure
+
+-- * Traversals from here on out
+
+instance UniqRenamable (GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph) where
+  uniqRename (CmmProc h lbl regs g)
+    = CmmProc <$> uniqRename h <*> uniqRename lbl <*> mapM uniqRename regs <*> uniqRename g
+  uniqRename (CmmData sec d)
+    = CmmData <$> uniqRename sec <*> uniqRename d
+
+instance UniqRenamable Section where
+  uniqRename (Section ty lbl) = Section ty <$> uniqRename lbl
+
+instance UniqRenamable RawCmmStatics where
+  uniqRename (CmmStaticsRaw lbl sts)
+    = CmmStaticsRaw <$> uniqRename lbl <*> mapM uniqRename sts
+
+instance UniqRenamable CmmStatic where
+  uniqRename = \case
+    CmmStaticLit l -> CmmStaticLit <$> uniqRename l
+    CmmUninitialised x -> pure $ CmmUninitialised x
+    CmmString x -> pure $ CmmString x
+    CmmFileEmbed f i -> pure $ CmmFileEmbed f i
+
+instance UniqRenamable CmmLit where
+  uniqRename = \case
+    CmmInt i w -> pure $ CmmInt i w
+    CmmFloat r w -> pure $ CmmFloat r w
+    CmmVec lits -> CmmVec <$> mapM uniqRename lits
+    CmmLabel lbl -> CmmLabel <$> uniqRename lbl
+    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
+    CmmHighStackMark -> pure CmmHighStackMark
+
+instance UniqRenamable a {- for 'Body' and on 'RawCmmStatics' -}
+  => UniqRenamable (LabelMap a) where
+  uniqRename = traverse uniqRename
+
+instance UniqRenamable CmmGraph where
+  uniqRename (CmmGraph e g) = CmmGraph e <$> uniqRename g
+
+instance UniqRenamable (Graph CmmNode n m) where
+  uniqRename = \case
+    GNil  -> pure GNil
+    GUnit block -> GUnit <$> uniqRename block
+    GMany m1 b m2 -> GMany <$> uniqRename m1 <*> uniqRename b <*> uniqRename m2
+
+instance UniqRenamable t => UniqRenamable (MaybeO n t) where
+  uniqRename (JustO x) = JustO <$> uniqRename x
+  uniqRename NothingO = pure NothingO
+
+instance UniqRenamable (Block CmmNode n m) where
+  uniqRename = \case
+    BlockCO n bn -> BlockCO <$> uniqRename n <*> uniqRename bn
+    BlockCC n1 bn n2 -> BlockCC <$> uniqRename n1 <*> uniqRename bn <*> uniqRename n2
+    BlockOC bn n -> BlockOC <$> uniqRename bn <*> uniqRename n
+                                                             
+    BNil    -> pure BNil
+    BMiddle n -> BMiddle <$> uniqRename n
+    BCat    b1 b2 -> BCat <$> uniqRename b1 <*> uniqRename b2
+    BSnoc   bn n -> BSnoc <$> uniqRename bn <*> uniqRename n
+    BCons   n bn -> BCons <$> uniqRename n <*> uniqRename bn
+
+instance UniqRenamable (CmmNode n m) where
+  uniqRename = \case
+    CmmEntry l t -> CmmEntry l <$> uniqRename t
+    CmmComment fs -> pure $ CmmComment fs
+    CmmTick tickish -> pure $ CmmTick tickish
+    CmmUnwind xs -> CmmUnwind <$> mapM uniqRename xs
+    CmmAssign reg e -> CmmAssign <$> uniqRename reg <*> uniqRename e
+    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
+    CmmCondBranch pred t f likely ->
+      CmmCondBranch <$> uniqRename pred <*> pure t <*> pure f <*> pure likely
+    CmmSwitch e sts -> CmmSwitch <$> uniqRename e <*> pure sts
+    CmmCall tgt cont regs args retargs retoff ->
+      CmmCall <$> uniqRename tgt <*> pure 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
+
+instance UniqRenamable GlobalReg where
+  uniqRename = pure
+
+instance UniqRenamable CmmExpr where
+  uniqRename = \case
+    CmmLit l -> CmmLit <$> uniqRename l
+    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
+    CmmRegOff r i -> CmmRegOff <$> uniqRename r <*> pure i
+
+instance UniqRenamable ForeignTarget where
+  uniqRename = \case
+    ForeignTarget e fc -> ForeignTarget <$> uniqRename e <*> pure fc
+    PrimTarget cmop -> pure $ PrimTarget cmop
+
+instance UniqRenamable CmmReg where
+  uniqRename = \case
+    CmmLocal l -> CmmLocal <$> uniqRename l
+    CmmGlobal x -> pure $ CmmGlobal x
+
+instance (UniqRenamable a, UniqRenamable b) => UniqRenamable (a, b) where
+  uniqRename (a, b) = (,) <$> uniqRename a <*> uniqRename b
+
+instance (UniqRenamable a) => UniqRenamable (Maybe a) where
+  uniqRename Nothing = pure Nothing
+  uniqRename (Just x) = Just <$> uniqRename x


=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -494,6 +494,8 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
                 FormatCMM
                 (vcat $ map (pprLiveCmmDecl platform) withLiveness)
 
+        -- ROMES:TODO: RENAME VIRTUAL REGISTERS DETERMINISTICALLY
+
         -- allocate registers
         (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear, raStats, stack_updt_blks) <-
          if ( ncgRegsGraph config || ncgRegsIterative config )
@@ -555,6 +557,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
                         , [], stack_updt_blks)
 
           else do
+
                 -- do linear register allocation
                 let reg_alloc proc = do
                        (alloced, maybe_more_stack, ra_stats) <-


=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -38,6 +38,7 @@ import GHC.Driver.Backend
 import qualified GHC.Data.ShortText as ST
 import GHC.Data.Stream           ( Stream )
 import qualified GHC.Data.Stream as Stream
+import GHC.Cmm.UniqueRenamer
 
 import GHC.Utils.TmpFs
 
@@ -94,11 +95,21 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g
   cmm_stream
   =
     do  {
+        -- To produce deterministic object code, we alpha-rename all Uniques to deterministic uniques before Cmm linting.
+        -- From here on out, the backend code generation can't use (non-deterministic) Uniques, or risk producing non-deterministic code.
+        -- 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 =
+                -- if gopt Opt_DeterministicObjects dflags
+
+                snd  <$> Stream.mapAccumL_ (fmap pure . detRenameUniques) emptyDetUFM cmm_stream
+
         -- Lint each CmmGroup as it goes past
         ; let linted_cmm_stream =
                  if gopt Opt_DoCmmLinting dflags
-                    then Stream.mapM do_lint cmm_stream
-                    else cmm_stream
+                    then Stream.mapM do_lint renamed_cmm_stream
+                    else renamed_cmm_stream
 
               do_lint cmm = withTimingSilent logger
                   (text "CmmLint"<+>brackets (ppr this_mod))
@@ -397,3 +408,4 @@ ipInitCode do_info_table platform this_mod
 
    ipe_buffer_decl =
        text "extern IpeBufferListNode" <+> ipe_buffer_label <> text ";"
+


=====================================
compiler/GHC/Types/Unique.hs
=====================================
@@ -249,6 +249,8 @@ use `deriving' because we want {\em precise} control of ordering
 -- the interface files are created, in particular we don't care about
 -- register allocation and code generation.
 -- To track progress on bit-for-bit determinism see #12262.
+--
+-- ROMES:TODO: Will need to update this ^ !
 
 eqUnique :: Unique -> Unique -> Bool
 eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2


=====================================
compiler/ghc.cabal.in
=====================================
@@ -260,6 +260,7 @@ Library
         GHC.Cmm.Switch
         GHC.Cmm.Switch.Implement
         GHC.Cmm.ThreadSanitizer
+        GHC.Cmm.UniqueRenamer
         GHC.CmmToAsm
         GHC.Cmm.LRegSet
         GHC.CmmToAsm.AArch64


=====================================
testsuite/tests/determinism/object/all.T
=====================================
@@ -1 +1 @@
-test('T12935', [extra_files(['cabal.project', 'check.sh'])], makefile_test, ['T12935'])
+# test('T12935', [extra_files(['cabal.project', 'check.sh'])], makefile_test, ['T12935'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f57af85c02d88610c645a33d134bd898f83af1b8...299bb8386f55247171feca88f35895607368865d

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f57af85c02d88610c645a33d134bd898f83af1b8...299bb8386f55247171feca88f35895607368865d
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/39c93187/attachment-0001.html>


More information about the ghc-commits mailing list