[Git][ghc/ghc][wip/T22010] Make uses of fromIntegral safer
Jaro Reinders (@Noughtmare)
gitlab at gitlab.haskell.org
Wed Jun 28 11:37:16 UTC 2023
Jaro Reinders pushed to branch wip/T22010 at Glasgow Haskell Compiler / GHC
Commits:
3bfe5e88 by Jaro Reinders at 2023-06-28T13:37:07+02:00
Make uses of fromIntegral safer
- - - - -
10 changed files:
- compiler/GHC/Builtin/Uniques.hs
- compiler/GHC/Cmm/CommonBlockElim.hs
- compiler/GHC/Cmm/Dominators.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/StgToJS/Symbols.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Types/Unique/Supply.hs
- compiler/GHC/Utils/Outputable.hs
Changes:
=====================================
compiler/GHC/Builtin/Uniques.hs
=====================================
@@ -1,4 +1,4 @@
-
+{-# LANGUAGE TypeApplications #-}
-- | This is where we define a mapping from Uniques to their associated
-- known-key Names for things associated with tuples and sums. We use this
@@ -66,8 +66,10 @@ import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain (assert)
import Data.Maybe
+import Data.Word (Word64)
-- | Get the 'Name' associated with a known-key 'Unique'.
knownUniqueName :: Unique -> Maybe Name
@@ -84,8 +86,8 @@ knownUniqueName u =
_ -> Nothing
where
(tag, n') = unpkUnique u
- -- Known unique names are guaranteed to fit in 'Int', so we don't need the whole 'Word64'.
- n = fromIntegral n'
+ -- Known unique names are guaranteed to fit in Int, so we don't need the whole Word64.
+ n = assert (isValidKnownKeyUnique u) (fromIntegral @Word64 @Int n')
{-
Note [Unique layout for unboxed sums]
@@ -281,7 +283,9 @@ isTupleTyConUnique u =
where
(tag, n) = unpkUnique u
(arity', i) = quotRem n 2
- arity = fromIntegral arity'
+ arity =
+ assert (arity' <= fromIntegral @Int @Word64 (maxBound :: Int))
+ (fromIntegral @Word64 @Int arity')
getTupleTyConName :: Boxity -> Int -> Name
getTupleTyConName boxity n =
=====================================
compiler/GHC/Cmm/CommonBlockElim.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
module GHC.Cmm.CommonBlockElim
( elimCommonBlocks
@@ -182,8 +183,10 @@ hash_block block =
cvt = fromInteger . toInteger
+ -- Since we are hashing, we can savely downcast Word64 to Word32 here.
+ -- Although a different hashing function may be more effective.
hash_unique :: Uniquable a => a -> Word32
- hash_unique = fromIntegral . getKey . getUnique
+ hash_unique = fromIntegral @Word64 @Word32 . getKey . getUnique
-- | Ignore these node types for equality
dont_care :: CmmNode O x -> Bool
=====================================
compiler/GHC/Cmm/Dominators.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeApplications #-}
module GHC.Cmm.Dominators
(
@@ -40,8 +41,6 @@ import GHC.Cmm
import GHC.Utils.Outputable( Outputable(..), text, int, hcat, (<+>))
import GHC.Utils.Misc
import GHC.Utils.Panic
-import GHC.Data.Word64Map (Word64Map)
-import GHC.Data.Word64Set (Word64Set)
import qualified GHC.Data.Word64Map as WM
import qualified GHC.Data.Word64Set as WS
@@ -132,6 +131,9 @@ graphWithDominators :: forall node .
-- The implementation uses the Lengauer-Tarjan algorithm from the x86
-- back end.
+-- Technically, we do not need Word64 here, however the dominators code
+-- has to accomodate Word64 for other uses.
+
graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap
where rpblocks = revPostorderFrom (graphMap g) (g_entry g)
rplabels' = map entryLabel rpblocks
@@ -149,9 +151,9 @@ graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap
blockIndex = labelIndex . entryLabel
bounds :: (Word64, Word64)
- bounds = (0, fromIntegral (length rpblocks - 1))
+ bounds = (0, fromIntegral @Int @Word64 (length rpblocks - 1))
- ltGraph :: [Block node C C] -> Word64Map Word64Set
+ ltGraph :: [Block node C C] -> LT.Graph
ltGraph [] = WM.empty
ltGraph (block:blocks) =
WM.insert
@@ -159,7 +161,7 @@ graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap
(WS.fromList $ map labelIndex $ successors block)
(ltGraph blocks)
- idom_array :: Array Word64 Word64
+ idom_array :: Array Word64 LT.Node
idom_array = array bounds $ LT.idom (0, ltGraph rpblocks)
domSet 0 = EntryNode
=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -156,7 +156,7 @@ mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv
header_bits = maybe mempty idTag maybe_target
idTag i = let (tag, u) = unpkUnique (getUnique i)
- in CHeader (char tag <> word (fromIntegral u))
+ in CHeader (char tag <> word64 u)
fun_args
| null arg_info = empty -- text "void"
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -333,7 +333,7 @@ handleRunStatus step expr bindings final_ids status history
let dflags = hsc_dflags hsc_env
let hmi = expectJust "handleRunStatus" $
lookupHptDirectly (hsc_HPT hsc_env)
- (mkUniqueGrimily (fromIntegral mod_uniq))
+ (mkUniqueIntGrimily mod_uniq)
modl = mi_module (hm_iface hmi)
breaks = getModBreaks hmi
@@ -366,7 +366,7 @@ handleRunStatus step expr bindings final_ids status history
apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
let hmi = expectJust "handleRunStatus" $
lookupHptDirectly (hsc_HPT hsc_env)
- (mkUniqueGrimily (fromIntegral mod_uniq))
+ (mkUniqueIntGrimily mod_uniq)
modl = mi_module (hm_iface hmi)
bp | is_exception = Nothing
| otherwise = Just (BreakInfo modl ix)
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -398,7 +398,7 @@ handleSeqHValueStatus interp unit_env eval_status =
resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
let hmi = expectJust "handleRunStatus" $
lookupHptDirectly (ue_hpt unit_env)
- (mkUniqueGrimily (fromIntegral mod_uniq))
+ (mkUniqueIntGrimily mod_uniq)
modl = mi_module (hm_iface hmi)
bp | is_exception = Nothing
| otherwise = Just (BreakInfo modl ix)
=====================================
compiler/GHC/StgToJS/Symbols.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeApplications #-}
-- | JS symbol generation
module GHC.StgToJS.Symbols
@@ -25,7 +26,7 @@ import qualified Data.ByteString.Lazy as BSL
--
-- Used for the sub indices.
intBS :: Int -> ByteString
-intBS = word64BS . fromIntegral
+intBS = word64BS . fromIntegral @Int @Word64
-- | Hexadecimal representation of a 64-bit word
--
=====================================
compiler/GHC/Types/Unique.hs
=====================================
@@ -19,6 +19,7 @@ Haskell).
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns, MagicHash #-}
+{-# LANGUAGE TypeApplications #-}
module GHC.Types.Unique (
-- * Main data types
@@ -30,7 +31,9 @@ module GHC.Types.Unique (
pprUniqueAlways,
+ mkTag,
mkUniqueGrimily,
+ mkUniqueIntGrimily,
getKey,
mkUnique, unpkUnique,
mkUniqueInt,
@@ -96,7 +99,7 @@ newtype Unique = MkUnique Word64
{-# INLINE uNIQUE_BITS #-}
uNIQUE_BITS :: Int
-uNIQUE_BITS = finiteBitSize (0 :: Word64) - UNIQUE_TAG_BITS
+uNIQUE_BITS = 64 - UNIQUE_TAG_BITS
{-
Now come the functions which construct uniques from their pieces, and vice versa.
@@ -137,6 +140,13 @@ newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u
uniqueMask :: Word64
uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1
+-- | Put the character in the highest bits of the Word64.
+-- This may truncate the character to UNIQUE_TAG_BITS.
+-- This function is used in @`mkSplitUniqSupply`@ so that it can
+-- precompute and share the tag part of the uniques it generates.
+mkTag :: Char -> Word64
+mkTag c = fromIntegral @Int @Word64 (ord c) `shiftL` uNIQUE_BITS
+
-- pop the Char in the top 8 bits of the Unique(Supply)
-- No 64-bit bugs here, as long as we have at least 32 bits. --JSM
@@ -148,17 +158,20 @@ mkUnique :: Char -> Word64 -> Unique -- Builds a unique from pieces
mkUnique c i
= MkUnique (tag .|. bits)
where
- tag = fromIntegral (ord c) `shiftL` uNIQUE_BITS
- bits = fromIntegral i .&. uniqueMask
+ tag = mkTag c
+ bits = i .&. uniqueMask
mkUniqueInt :: Char -> Int -> Unique
-mkUniqueInt c i = mkUnique c (fromIntegral i)
+mkUniqueInt c i = mkUnique c (fromIntegral @Int @Word64 i)
+
+mkUniqueIntGrimily :: Int -> Unique
+mkUniqueIntGrimily = MkUnique . fromIntegral @Int @Word64
unpkUnique (MkUnique u)
= let
- -- as long as the Char may have its eighth bit set, we
- -- really do need the logical right-shift here!
- tag = chr (fromIntegral (u `shiftR` uNIQUE_BITS))
+ -- The potentially truncating use of fromIntegral here is safe
+ -- because the argument is just the tag bits after shifting.
+ tag = chr (fromIntegral @Word64 @Int (u `shiftR` uNIQUE_BITS))
i = u .&. uniqueMask
in
(tag, i)
@@ -188,10 +201,10 @@ hasKey :: Uniquable a => a -> Unique -> Bool
x `hasKey` k = getUnique x == k
instance Uniquable FastString where
- getUnique fs = mkUniqueGrimily (fromIntegral (uniqueOfFS fs))
+ getUnique fs = mkUniqueIntGrimily (uniqueOfFS fs)
instance Uniquable Int where
- getUnique i = mkUniqueGrimily (fromIntegral i)
+ getUnique i = mkUniqueIntGrimily i
instance Uniquable Word64 where
getUnique i = MkUnique i
@@ -319,11 +332,13 @@ Code stolen from Lennart.
w64ToBase62 :: Word64 -> String
w64ToBase62 n_ = go n_ ""
where
+ -- The uses of potentially truncating uses fromIntegral here are safe
+ -- because the argument is guaranteed to be less than 62 in both cases.
go n cs | n < 62
- = let !c = chooseChar62 (fromIntegral n) in c : cs
+ = let !c = chooseChar62 (fromIntegral @Word64 @Int n) in c : cs
| otherwise
= go q (c : cs) where (!q, r) = quotRem n 62
- !c = chooseChar62 (fromIntegral r)
+ !c = chooseChar62 (fromIntegral @Word64 @Int r)
chooseChar62 :: Int -> Char
{-# INLINE chooseChar62 #-}
=====================================
compiler/GHC/Types/Unique/Supply.hs
=====================================
@@ -39,7 +39,6 @@ import GHC.IO
import GHC.Utils.Monad
import Control.Monad
-import Data.Char
import Data.Word
import GHC.Exts( Ptr(..), noDuplicate#, oneShot )
import Foreign.Storable
@@ -214,7 +213,7 @@ mkSplitUniqSupply c
= unsafeDupableInterleaveIO (IO mk_supply)
where
- !mask = fromIntegral (ord c) `unsafeShiftL` uNIQUE_BITS
+ !mask = mkTag c
-- Here comes THE MAGIC: see Note [How the unique supply works]
-- This is one of the most hammered bits in the whole compiler
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -37,7 +37,7 @@ module GHC.Utils.Outputable (
spaceIfSingleQuote,
isEmpty, nest,
ptext,
- int, intWithCommas, integer, word, float, double, rational, doublePrec,
+ int, intWithCommas, integer, word64, word, float, double, rational, doublePrec,
parens, cparen, brackets, braces, quotes, quote,
doubleQuotes, angleBrackets,
semi, comma, colon, dcolon, space, equals, dot, vbar,
@@ -681,6 +681,7 @@ ptext :: PtrString -> SDoc
int :: IsLine doc => Int -> doc
integer :: IsLine doc => Integer -> doc
word :: Integer -> SDoc
+word64 :: IsLine doc => Word64 -> doc
float :: IsLine doc => Float -> doc
double :: IsLine doc => Double -> doc
rational :: Rational -> SDoc
@@ -698,6 +699,8 @@ double n = text $ show n
{-# INLINE CONLIKE rational #-}
rational n = text $ show n
-- See Note [Print Hexadecimal Literals] in GHC.Utils.Ppr
+{-# INLINE CONLIKE word64 #-}
+word64 n = text $ show n
{-# INLINE CONLIKE word #-}
word n = sdocOption sdocHexWordLiterals $ \case
True -> docToSDoc $ Pretty.hex n
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3bfe5e88eca197c7a9d9f9c46717a1c31c13aaaf
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3bfe5e88eca197c7a9d9f9c46717a1c31c13aaaf
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/20230628/9a0a7b2e/attachment-0001.html>
More information about the ghc-commits
mailing list