Commit 4ba73e00 authored by Luite Stegeman's avatar Luite Stegeman Committed by Marge Bot

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

parent 6efe04de
Pipeline #5961 failed with stages
in 71 minutes and 1 second
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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.
--
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment