[Git][ghc/ghc][master] Constant-folding: don't pass through GHC's Int/Word (fix #11704)
Marge Bot
gitlab at gitlab.haskell.org
Tue Nov 3 22:42:34 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
37f0434d by Sylvain Henry at 2020-11-03T17:42:26-05:00
Constant-folding: don't pass through GHC's Int/Word (fix #11704)
Constant-folding rules for integerToWord/integerToInt were performing
the following coercions at compilation time:
integerToWord: target's Integer -> ghc's Word -> target's Word
integerToInt : target's Integer -> ghc's Int -> target's Int
1) It was wrong for cross-compilers when GHC's word size is smaller than
the target one. This patch avoids passing through GHC's word-sized
types:
integerToWord: target's Integer -> ghc's Integer -> target's Word
integerToInt : target's Integer -> ghc's Integer -> target's Int
2) Additionally we didn't wrap the target word/int literal to make it
fit into the target's range! This broke the invariant of literals
only containing values in range.
The existing code is wrong only with a 64-bit cross-compiling GHC,
targeting a 32-bit platform, and performing constant folding on a
literal that doesn't fit in a 32-bit word. If GHC was built with
DEBUG, the assertion in GHC.Types.Literal.mkLitWord would fail.
Otherwise the bad transformation would go unnoticed.
- - - - -
4 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/HsToCore/Foreign/Decl.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -27,8 +27,8 @@ module GHC.Core (
mkLet, mkLets, mkLetNonRec, mkLetRec, mkLams,
mkApps, mkTyApps, mkCoApps, mkVarApps, mkTyArg,
- mkIntLit, mkIntLitInt,
- mkWordLit, mkWordLitWord,
+ mkIntLit, mkIntLitWrap,
+ mkWordLit, mkWordLitWrap,
mkWord64LitWord64, mkInt64LitInt64,
mkCharLit, mkStringLit,
mkFloatLit, mkFloatLitFloat,
@@ -1977,23 +1977,25 @@ mkTyArg ty
-- | Create a machine integer literal expression of type @Int#@ from an @Integer at .
-- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'
-mkIntLit :: Platform -> Integer -> Expr b
--- | Create a machine integer literal expression of type @Int#@ from an @Int at .
--- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'
-mkIntLitInt :: Platform -> Int -> Expr b
+mkIntLit :: Platform -> Integer -> Expr b
+mkIntLit platform n = Lit (mkLitInt platform n)
-mkIntLit platform n = Lit (mkLitInt platform n)
-mkIntLitInt platform n = Lit (mkLitInt platform (toInteger n))
+-- | Create a machine integer literal expression of type @Int#@ from an
+-- @Integer@, wrapping if necessary.
+-- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'
+mkIntLitWrap :: Platform -> Integer -> Expr b
+mkIntLitWrap platform n = Lit (mkLitIntWrap platform n)
-- | Create a machine word literal expression of type @Word#@ from an @Integer at .
-- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'
-mkWordLit :: Platform -> Integer -> Expr b
--- | Create a machine word literal expression of type @Word#@ from a @Word at .
--- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'
-mkWordLitWord :: Platform -> Word -> Expr b
+mkWordLit :: Platform -> Integer -> Expr b
+mkWordLit platform w = Lit (mkLitWord platform w)
-mkWordLit platform w = Lit (mkLitWord platform w)
-mkWordLitWord platform w = Lit (mkLitWord platform (toInteger w))
+-- | Create a machine word literal expression of type @Word#@ from an
+-- @Integer@, wrapping if necessary.
+-- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'
+mkWordLitWrap :: Platform -> Integer -> Expr b
+mkWordLitWrap platform w = Lit (mkLitWordWrap platform w)
mkWord64LitWord64 :: Word64 -> Expr b
mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w))
=====================================
compiler/GHC/Core/Make.hs
=====================================
@@ -13,7 +13,7 @@ module GHC.Core.Make (
sortQuantVars, castBottomExpr,
-- * Constructing boxed literals
- mkWordExpr, mkWordExprWord,
+ mkWordExpr,
mkIntExpr, mkIntExprInt, mkUncheckedIntExpr,
mkIntegerExpr, mkNaturalExpr,
mkFloatExpr, mkDoubleExpr,
@@ -263,16 +263,12 @@ mkUncheckedIntExpr i = mkCoreConApps intDataCon [Lit (mkLitIntUnchecked i)]
-- | Create a 'CoreExpr' which will evaluate to the given @Int@
mkIntExprInt :: Platform -> Int -> CoreExpr -- Result = I# i :: Int
-mkIntExprInt platform i = mkCoreConApps intDataCon [mkIntLitInt platform i]
+mkIntExprInt platform i = mkCoreConApps intDataCon [mkIntLit platform (fromIntegral i)]
-- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value
mkWordExpr :: Platform -> Integer -> CoreExpr
mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w]
--- | Create a 'CoreExpr' which will evaluate to the given @Word@
-mkWordExprWord :: Platform -> Word -> CoreExpr
-mkWordExprWord platform w = mkCoreConApps wordDataCon [mkWordLitWord platform w]
-
-- | Create a 'CoreExpr' which will evaluate to the given @Integer@
mkIntegerExpr :: Integer -> CoreExpr -- Result :: Integer
mkIntegerExpr i = Lit (mkLitInteger i)
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -1348,10 +1348,10 @@ builtinBignumRules _ =
, rule_IntegerFromLitNum "Int64# -> Integer" integerFromInt64Name
, rule_IntegerFromLitNum "Word64# -> Integer" integerFromWord64Name
, rule_IntegerFromLitNum "Natural -> Integer" integerFromNaturalName
- , rule_convert "Integer -> Word#" integerToWordName mkWordLitWord
- , rule_convert "Integer -> Int#" integerToIntName mkIntLitInt
- , rule_convert "Integer -> Word64#" integerToWord64Name (\_ -> mkWord64LitWord64)
- , rule_convert "Integer -> Int64#" integerToInt64Name (\_ -> mkInt64LitInt64)
+ , rule_convert "Integer -> Word#" integerToWordName mkWordLitWrap
+ , rule_convert "Integer -> Int#" integerToIntName mkIntLitWrap
+ , rule_convert "Integer -> Word64#" integerToWord64Name (\_ -> mkWord64LitWord64 . fromInteger)
+ , rule_convert "Integer -> Int64#" integerToInt64Name (\_ -> mkInt64LitInt64 . fromInteger)
, rule_binopi "integerAdd" integerAddName (+)
, rule_binopi "integerSub" integerSubName (-)
, rule_binopi "integerMul" integerMulName (*)
@@ -1366,9 +1366,9 @@ builtinBignumRules _ =
, rule_unop "integerSignum" integerSignumName signum
, rule_binop_Ordering "integerCompare" integerCompareName compare
, rule_encodeFloat "integerEncodeFloat" integerEncodeFloatName mkFloatLitFloat
- , rule_convert "integerToFloat" integerToFloatName (\_ -> mkFloatLitFloat)
+ , rule_convert "integerToFloat" integerToFloatName (\_ -> mkFloatLitFloat . fromInteger)
, rule_encodeFloat "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble
- , rule_convert "integerToDouble" integerToDoubleName (\_ -> mkDoubleLitDouble)
+ , rule_convert "integerToDouble" integerToDoubleName (\_ -> mkDoubleLitDouble . fromInteger)
, rule_binopi "integerGcd" integerGcdName gcd
, rule_binopi "integerLcm" integerLcmName lcm
, rule_binopi "integerAnd" integerAndName (.&.)
@@ -1659,12 +1659,11 @@ match_integerBit _ _ _ _ = Nothing
-------------------------------------------------
-match_Integer_convert :: Num a
- => (Platform -> a -> Expr CoreBndr)
+match_Integer_convert :: (Platform -> Integer -> Expr CoreBndr)
-> RuleFun
match_Integer_convert convert env id_unf _ [xl]
| Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl
- = Just (convert (roPlatform env) (fromInteger x))
+ = Just (convert (roPlatform env) x)
match_Integer_convert _ _ _ _ _ = Nothing
match_Integer_unop :: (Integer -> Integer) -> RuleFun
=====================================
compiler/GHC/HsToCore/Foreign/Decl.hs
=====================================
@@ -453,7 +453,7 @@ dsFExportDynamic id co0 cconv = do
to be entered using an external calling convention
(stdcall, ccall).
-}
- adj_args = [ mkIntLitInt platform (ccallConvToInt cconv)
+ adj_args = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv))
, Var stbl_value
, Lit (LitLabel fe_nm mb_sz_args IsFunction)
, Lit (mkLitString typestring)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37f0434d65fa0891a961504c8882893fad7609c6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37f0434d65fa0891a961504c8882893fad7609c6
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/20201103/1dc11495/attachment-0001.html>
More information about the ghc-commits
mailing list