[Git][ghc/ghc][wip/t25510] Typeable: Fix module locations of some definitions in GHC.Types

[Matthew Pickering (@mpickering)]

Matthew Pickering pushed to branch wip/t25510 at Glasgow Haskell Compiler / GHC


Commits:
c989d063 by Matthew Pickering at 2022-12-07T16:37:01+00:00
Typeable: Fix module locations of some definitions in GHC.Types

There was some confusion in Data.Typeable about which module certain
wired-in things were defined in. Just because something is wired-in
doesn't mean it comes from GHC.Prim, in particular things like LiftedRep
and RuntimeRep are defined in GHC.Types and that's the end of the story.

Things like Int#, Float# etc are defined in GHC.Prim as they have no
Haskell definition site at all so we need to generate type
representations for them (which live in GHC.Types).

Fixes #22510

- - - - -


4 changed files:

- compiler/GHC/Tc/Instance/Typeable.hs
- + testsuite/tests/typecheck/should_run/T22510.hs
- + testsuite/tests/typecheck/should_run/T22510.stdout
- testsuite/tests/typecheck/should_run/all.T


Changes:

=====================================
compiler/GHC/Tc/Instance/Typeable.hs
=====================================
@@ -172,7 +172,7 @@ mkTypeableBinds
        } } }
   where
     needs_typeable_binds tc
-      | tc `elem` [runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon]
+      | tc `elem` ghcTypesTypeableTyCons
       = False
       | otherwise =
           isAlgTyCon tc
@@ -335,7 +335,14 @@ mkPrimTypeableTodos
                    ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id
                                             ghcPrimTypeableTyCons
 
-                   ; return ( gbl_env' , [todo1, todo2])
+                   ; tcg_env <- getGblEnv
+                   ; let mod_id = case tcg_tr_module tcg_env of  -- Should be set by now
+                                   Just mod_id -> mod_id
+                                   Nothing     -> pprPanic "tcMkTypeableBinds" empty
+
+                   ; todo3 <- todoForTyCons gHC_TYPES mod_id ghcTypesTypeableTyCons
+
+                   ; return ( gbl_env' , [todo1, todo2, todo3])
                    }
            else do gbl_env <- getGblEnv
                    return (gbl_env, [])
@@ -350,12 +357,18 @@ mkPrimTypeableTodos
 -- Note [Built-in syntax and the OrigNameCache] in "GHC.Iface.Env" for more.
 ghcPrimTypeableTyCons :: [TyCon]
 ghcPrimTypeableTyCons = concat
-    [ [ runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon ]
-    , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE]
+    [ map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE]
     , map sumTyCon [2..mAX_SUM_SIZE]
     , primTyCons
     ]
 
+-- | These are types which are defined in GHC.Types but are needed in order to
+-- typecheck the other generated bindings, therefore to avoid ordering issues we
+-- generate them up-front along with the bindings from GHC.Prim.
+ghcTypesTypeableTyCons :: [TyCon]
+ghcTypesTypeableTyCons = [ runtimeRepTyCon, levityTyCon
+                         , vecCountTyCon, vecElemTyCon ]
+
 data TypeableStuff
     = Stuff { platform       :: Platform        -- ^ Target platform
             , trTyConDataCon :: DataCon         -- ^ of @TyCon@


=====================================
testsuite/tests/typecheck/should_run/T22510.hs
=====================================
@@ -0,0 +1,36 @@
+{-# LANGUAGE MagicHash, UnboxedTuples, UnboxedSums, ScopedTypeVariables, TypeApplications, AllowAmbiguousTypes #-}
+module Main where
+
+import Type.Reflection
+import Data.Proxy
+import GHC.Types
+import GHC.Prim
+
+moduleOf :: forall a . Typeable a => String
+moduleOf = case someTypeRep (Proxy @a) of
+              SomeTypeRep tr -> (show tr ++ ": " ++ (tyConModule $ typeRepTyCon tr))
+
+main = do
+  -- These are in GHC.Types
+  putStrLn $ moduleOf @Levity
+  putStrLn $ moduleOf @'Lifted
+  putStrLn $ moduleOf @RuntimeRep
+  putStrLn $ moduleOf @'IntRep
+  putStrLn $ moduleOf @'BoxedRep
+  putStrLn $ moduleOf @'Lifted
+  putStrLn $ moduleOf @VecCount
+  putStrLn $ moduleOf @'Vec2
+  putStrLn $ moduleOf @VecElem
+  putStrLn $ moduleOf @'Int8ElemRep
+
+  -- This is from GHC.Tuple
+  putStrLn $ moduleOf @((),())
+
+  -- These are in GHC.Prim
+  putStrLn $ moduleOf @(# () , () #)
+--  putStrLn $ moduleOf @(# () | () #)
+--
+  putStrLn $ moduleOf @(Int64#)
+  putStrLn $ moduleOf @(Word64#)
+  putStrLn $ moduleOf @TYPE
+  putStrLn $ moduleOf @CONSTRAINT


=====================================
testsuite/tests/typecheck/should_run/T22510.stdout
=====================================
@@ -0,0 +1,16 @@
+Levity: GHC.Types
+'Lifted: GHC.Types
+RuntimeRep: GHC.Types
+'IntRep: GHC.Types
+'BoxedRep: GHC.Types
+'Lifted: GHC.Types
+VecCount: GHC.Types
+'Vec2: GHC.Types
+VecElem: GHC.Types
+'Int8ElemRep: GHC.Types
+((),()): GHC.Tuple.Prim
+(#,#) ('BoxedRep 'Lifted) ('BoxedRep 'Lifted) () (): GHC.Prim
+Int64#: GHC.Prim
+Word64#: GHC.Prim
+TYPE: GHC.Prim
+CONSTRAINT: GHC.Prim


=====================================
testsuite/tests/typecheck/should_run/all.T
=====================================
@@ -163,3 +163,4 @@ test('T19397M3', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo'])
 test('T19397M4', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo'])
 test('T19667', normal, compile_and_run, ['-fhpc'])
 test('T20768', normal, compile_and_run, [''])
+test('T22510', normal, compile_and_run, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c989d063cb3ceb3e79106db6f33c0518d40f9463

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c989d063cb3ceb3e79106db6f33c0518d40f9463
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/20221207/05f9b915/attachment-0001.html>