fix Template Haskell cross compilation on 64 bit compiler with 32 bit target

5 files changed, 18 insertions, 13 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 7e13fdcc36..303c7a08d3 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1920,7 +1920,7 @@ globalVar name
         ; rep2 mk_varg [pkg,mod,occ] }
   | otherwise
   = do  { MkC occ <- nameLit name
-        ; MkC uni <- coreIntLit (getKey (getUnique name))
+        ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name))
         ; rep2 mkNameLName [occ,uni] }
   where
       mod = ASSERT( isExternalName name) nameModule name
@@ -2717,6 +2717,9 @@ coreIntLit :: Int -> DsM (Core Int)
 coreIntLit i = do dflags <- getDynFlags
                   return (MkC (mkIntExprInt dflags i))
 
+coreIntegerLit :: Integer -> DsM (Core Integer)
+coreIntegerLit i = fmap MkC (mkIntegerExpr i)
+
 coreVar :: Id -> Core TH.Name   -- The Id has type Name
 coreVar id = MkC (Var id)
 
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 57aaefb830..2292a9fea4 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -1824,8 +1824,8 @@ thRdrName loc ctxt_ns th_occ th_name
   = case th_name of
      TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod
      TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ
-     TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)
-     TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)
+     TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc)
+     TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc)
      TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name
               | otherwise                           -> mkRdrUnqual $! occ
               -- We check for built-in syntax here, because the TH
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 845e2029ed..3434b68615 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -922,7 +922,7 @@ To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
 
 instance TH.Quasi TcM where
   qNewName s = do { u <- newUnique
-                  ; let i = getKey u
+                  ; let i = toInteger (getKey u)
                   ; return (TH.mkNameU s i) }
 
   -- 'msg' is forced to ensure exceptions don't escape,
@@ -1947,8 +1947,9 @@ reify_tc_app tc tys
 ------------------------------
 reifyName :: NamedThing n => n -> TH.Name
 reifyName thing
-  | isExternalName name = mk_varg pkg_str mod_str occ_str
-  | otherwise           = TH.mkNameU occ_str (getKey (getUnique name))
+  | isExternalName name
+              = mk_varg pkg_str mod_str occ_str
+  | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name))
         -- Many of the things we reify have local bindings, and
         -- NameL's aren't supposed to appear in binding positions, so
         -- we use NameU.  When/if we start to reify nested things, that
diff --git a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs
index 7e05d05d83..ac0679a93e 100644
--- a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs
@@ -36,14 +36,14 @@ module Language.Haskell.TH.PprLib (
 
 
 import Language.Haskell.TH.Syntax
-    (Name(..), showName', NameFlavour(..), NameIs(..))
+    (Uniq, Name(..), showName', NameFlavour(..), NameIs(..))
 import qualified Text.PrettyPrint as HPJ
 import Control.Monad (liftM, liftM2, ap)
 import Language.Haskell.TH.Lib.Map ( Map )
 import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty )
 import Prelude hiding ((<>))
 
-infixl 6 <> 
+infixl 6 <>
 infixl 6 <+>
 infixl 5 $$, $+$
 
@@ -117,7 +117,7 @@ punctuate :: Doc -> [Doc] -> [Doc]
 -- ---------------------------------------------------------------------------
 -- The "implementation"
 
-type State = (Map Name Name, Int)
+type State = (Map Name Name, Uniq)
 data PprM a = PprM { runPprM :: State -> (a, State) }
 
 pprName :: Name -> Doc
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 14b9de263c..dfcdfd5f17 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -155,7 +155,7 @@ badIO op = do   { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
                 ; fail "Template Haskell failure" }
 
 -- Global variable to generate unique symbols
-counter :: IORef Int
+counter :: IORef Uniq
 {-# NOINLINE counter #-}
 counter = unsafePerformIO (newIORef 0)
 
@@ -1299,8 +1299,8 @@ instance Ord Name where
 data NameFlavour
   = NameS           -- ^ An unqualified name; dynamically bound
   | NameQ ModName   -- ^ A qualified name; dynamically bound
-  | NameU !Int      -- ^ A unique local name
-  | NameL !Int      -- ^ Local name bound outside of the TH AST
+  | NameU !Uniq     -- ^ A unique local name
+  | NameL !Uniq     -- ^ Local name bound outside of the TH AST
   | NameG NameSpace PkgName ModName -- ^ Global name bound outside of the TH AST:
                 -- An original name (occurrences only, not binders)
                 -- Need the namespace too to be sure which
@@ -1313,7 +1313,8 @@ data NameSpace = VarName        -- ^ Variables
                                 -- in the same name space for now.
                deriving( Eq, Ord, Show, Data, Generic )
 
-type Uniq = Int
+-- | @Uniq@ is used by GHC to distinguish names from each other.
+type Uniq = Integer
 
 -- | The name without its module prefix.
 --