From 1cca12edaafb40a4700e5cd81cad7708ea611cd2 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Mon, 2 Nov 2020 14:42:07 +0100 Subject: 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. --- compiler/GHC/Core.hs | 30 ++++++++++++++++-------------- compiler/GHC/Core/Make.hs | 8 ++------ compiler/GHC/Core/Opt/ConstantFold.hs | 17 ++++++++--------- compiler/GHC/HsToCore/Foreign/Decl.hs | 2 +- 4 files changed, 27 insertions(+), 30 deletions(-) diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 5e13b4e275..4d86e44170 100644 --- a/compiler/GHC/Core.hs +++ b/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, @@ -1973,23 +1973,25 @@ mkTyArg ty -- | Create a machine integer literal expression of type @Int#@ from an @Integer@. -- 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@. --- 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@. -- 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@. --- 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)) diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 7bc9c161a5..ca46a4a6ac 100644 --- a/compiler/GHC/Core/Make.hs +++ b/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, @@ -260,16 +260,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) diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index 4f17b85903..d3ff68cedc 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -1339,10 +1339,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 (*) @@ -1357,9 +1357,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 (.&.) @@ -1662,12 +1662,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 diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index 78eb53cd4d..5d193cba99 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -447,7 +447,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) -- cgit v1.2.1