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 files changed, 27 insertions, 30 deletions

diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index a6c1c282ab..57976e836a 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,
@@ -1977,23 +1977,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 2ce1f2c870..6d6dd38b29 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,
@@ -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)
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 73b266de11..52fd2bbf8e 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/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
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index 4d6abc4132..e50db56eec 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/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)