[Git][ghc/ghc][wip/angerman/ghcjs-th] fix Template Haskell cross compilation on 64 bit compiler with 32 bit target

[Moritz Angermann]

Moritz Angermann pushed to branch wip/angerman/ghcjs-th at Glasgow Haskell Compiler / GHC


Commits:
77c1e304 by Luite Stegeman at 2019-05-16T02:17:36Z
fix Template Haskell cross compilation on 64 bit compiler with 32 bit target

- - - - -


5 changed files:

- compiler/deSugar/DsMeta.hs
- compiler/hsSyn/Convert.hs
- compiler/typecheck/TcSplice.hs
- libraries/template-haskell/Language/Haskell/TH/PprLib.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs


Changes:

=====================================
compiler/deSugar/DsMeta.hs
=====================================
@@ -1947,7 +1947,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
@@ -2744,6 +2744,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)
 


=====================================
compiler/hsSyn/Convert.hs
=====================================
@@ -1831,8 +1831,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


=====================================
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


=====================================
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


=====================================
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.
 --



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/77c1e3047e7a6f5ad3ad3ed346e3a9729050d8d2

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/77c1e3047e7a6f5ad3ad3ed346e3a9729050d8d2
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/20190515/358a6f10/attachment-0001.html>