[Git][ghc/ghc][wip/romes/12935] MP fixes, don't rename external names

[Matthew Pickering (@mpickering)]

Matthew Pickering pushed to branch wip/romes/12935 at Glasgow Haskell Compiler / GHC


Commits:
c4afb742 by Matthew Pickering at 2024-07-10T15:31:22+01:00
MP fixes, don't rename external names

- - - - -


3 changed files:

- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/UniqueRenamer.hs
- testsuite/tests/determinism/object/check.sh


Changes:

=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -343,6 +343,10 @@ newtype NeedExternDecl
 -- This is non-deterministic but we do not currently support deterministic
 -- code-generation. See Note [Unique Determinism and code generation]
 instance Ord CLabel where
+  compare (IdLabel a1 b1 c1)
+          (IdLabel a2 b2 c2)
+          | isExternalName a1, isExternalName a2 = stableNameCmp a1 a2 S.<> compare b1 b2 S.<> compare c1 c2
+
   compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) =
     -- Comparing names here should deterministic because all unique should have been renamed deterministically ......
     compare a1 a2 S.<>
@@ -1874,8 +1878,10 @@ returns True.
 -- however, the input to layout must be deterministic to produce deterministic layout.
 -- Which means we could avoid renaming it here, as long as we guarantee the labels are produced deterministically (which we could, perhaps by using a det supply in fcode)
 mapInternalNonDetUniques :: Applicative m => (Unique -> m Unique) -> CLabel -> m CLabel
-mapInternalNonDetUniques f = \case
-  IdLabel name cafInfo idLabelInfo -> IdLabel . setNameUnique name <$> f (nameUnique name) <*> pure cafInfo <*> pure idLabelInfo
+mapInternalNonDetUniques f x = case x of
+  IdLabel name cafInfo idLabelInfo
+    | not (isExternalName name) -> IdLabel . setNameUnique name <$> f (nameUnique name) <*> pure cafInfo <*> pure idLabelInfo
+    | otherwise -> pure x
   cl at CmmLabel{} -> pure cl
   -- ROMES:TODO: what about `RtsApFast NonDetFastString`?
   RtsLabel rtsLblInfo -> pure $ RtsLabel rtsLblInfo


=====================================
compiler/GHC/Cmm/UniqueRenamer.hs
=====================================
@@ -26,6 +26,9 @@ import GHC.Utils.Outputable as Outputable
 import Data.Tuple (swap)
 import GHC.Types.Id
 import GHC.Types.Unique.DSM
+import GHC.Types.Name hiding (varName)
+import GHC.Types.Var
+
 
 {-
 --------------------------------------------------------------------------------
@@ -72,7 +75,7 @@ renameDetUniq uq = do
     Nothing -> do
       new_w <- gets supply -- New deterministic unique in this `DetRnM`
       let (tag, _) = unpkUnique uq
-          det_uniq = mkUnique tag new_w
+          det_uniq = mkUnique 'Q' new_w
       modify' (\DetUniqFM{mapping, supply} ->
         -- Update supply and mapping
         DetUniqFM
@@ -94,7 +97,9 @@ detRenameCLabel = mapInternalNonDetUniques renameDetUniq
 
 -- | We want to rename uniques in Ids, but ONLY internal ones.
 detRenameId :: Id -> DetRnM Id
-detRenameId i = setIdUnique i <$> renameDetUniq (getUnique i)
+detRenameId i
+  | isExternalName (varName i) = return i
+  | otherwise = setIdUnique i <$> renameDetUniq (getUnique i)
 
 --------------------------------------------------------------------------------
 -- Traversals


=====================================
testsuite/tests/determinism/object/check.sh
=====================================
@@ -39,10 +39,44 @@ compareObjs() {
     done
 }
 
+# $1 = objects
+# $2 = extra flags
+compareHis() {
+    for o in $2
+    do
+        echo $1 --show-iface $o
+        echo "--------------------------------------------------------------------------------"
+        # Compare the object dumps except for the first line which prints the file path
+        $1 --show-iface Cabal-3.12.0.0/hiout1/$o > dump1
+        $1 --show-iface Cabal-3.12.0.0/hiout2/$o > dump2
+        diff -C3 dump1 dump2 && echo "OK-hi"
+        echo "--------------------------------------------------------------------------------"
+    done
+}
+
+#if diff -r Cabal-3.12.0.0/hiout1 Cabal-3.12.0.0/hiout2
+#then
+#    echo "OK-hi"
+#else
+#    echo "--------------------------------------------------------------------------------"
+#    echo "Comparing all objects (1. headers, 2. disassembly). Stopping at first failure..."
+#    echo "--------------------------------------------------------------------------------"
+#
+#
+#    pushd Cabal-3.12.0.0/hiout1 >/dev/null
+#    OBJS=$(find . -type f)
+#    popd >/dev/null
+#
+#    compareHis "/home/matt/ghc-rodrigo/_build/stage1/bin/ghc" "$OBJS"
+#
+#    exit 1
+#
+#fi
+
 # Big fast check
 if diff -r Cabal-3.12.0.0/out1 Cabal-3.12.0.0/out2
 then
-    echo "OK"
+    echo "OK-obj"
 else
     echo "--------------------------------------------------------------------------------"
     echo "Comparing all objects (1. headers, 2. disassembly). Stopping at first failure..."
@@ -56,6 +90,7 @@ else
     compareObjs "$OBJS" "--all-headers"
 
     compareObjs "$OBJS" "--disassemble-all"
+    exit 1
 
 fi
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c4afb742fbba7b3a8cdbad3b770adab8105224b1

-- 
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c4afb742fbba7b3a8cdbad3b770adab8105224b1
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/20240710/6ab0485d/attachment-0001.html>