HACKING.md

@@ -30,7 +30,7 @@ find an overview here:
 Next, clone the repository and all the associated libraries:
 
 ```
-$ git clone --recursive git://git.haskell.org/ghc.git
+$ git clone --recursive git@gitlab.haskell.org:ghc/ghc.git
 ```
 
 On Windows, you need an extra repository containing some build tools.

README.md

@@ -26,7 +26,7 @@ There are two ways to get a source tree:
 
  2. *Check out the source code from git*
 
-        $ git clone --recursive git://git.haskell.org/ghc.git
+        $ git clone --recursive git@gitlab.haskell.org:ghc/ghc.git
 
   Note: cloning GHC from Github requires a special setup. See [Getting a GHC
   repository from Github][7].

boot

@@ -50,7 +50,7 @@ def check_for_url_rewrites():
 
             Or start over, and clone the GHC repository from the haskell server:
 
-              git clone --recursive git://git.haskell.org/ghc.git
+              git clone --recursive git@gitlab.haskell.org:ghc/ghc.git
 
             For more information, see:
               * https://ghc.haskell.org/trac/ghc/wiki/Newcomers or

compiler/basicTypes/PatSyn.hs

@@ -19,7 +19,7 @@ module PatSyn (
         patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
         patSynFieldType,
 
-        tidyPatSynIds, pprPatSynType
+        updatePatSynIds, pprPatSynType
     ) where
 
 #include "HsVersions.h"
@@ -417,8 +417,8 @@ patSynMatcher = psMatcher
 patSynBuilder :: PatSyn -> Maybe (Id, Bool)
 patSynBuilder = psBuilder
 
-tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
-tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })
+updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
+updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })
   = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder }
   where
     tidy_pr (id, dummy) = (tidy_fn id, dummy)

compiler/coreSyn/CoreTidy.hs

@@ -9,7 +9,7 @@ The code for *top-level* bindings is in TidyPgm.
 
 {-# LANGUAGE CPP #-}
 module CoreTidy (
-        tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding
+        tidyExpr, tidyRule, tidyRules, tidyUnfolding
     ) where
 
 #include "HsVersions.h"

compiler/deSugar/Check.hs

@@ -39,6 +39,7 @@ import FastString
 import DataCon
 import PatSyn
 import HscTypes (CompleteMatch(..))
+import BasicTypes (Boxity(..))
 
 import DsMonad
 import TcSimplify    (tcCheckSatisfiability)
@@ -1072,12 +1073,17 @@ translatePat fam_insts pat = case pat of
   TuplePat tys ps boxity -> do
     tidy_ps <- translatePatVec fam_insts (map unLoc ps)
     let tuple_con = RealDataCon (tupleDataCon boxity (length ps))
-    return [vanillaConPattern tuple_con tys (concat tidy_ps)]
+        tys' = case boxity of
+                 Boxed -> tys
+                 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+                 Unboxed -> map getRuntimeRep tys ++ tys
+    return [vanillaConPattern tuple_con tys' (concat tidy_ps)]
 
   SumPat ty p alt arity -> do
     tidy_p <- translatePat fam_insts (unLoc p)
     let sum_con = RealDataCon (sumDataCon alt arity)
-    return [vanillaConPattern sum_con ty tidy_p]
+    -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+    return [vanillaConPattern sum_con (map getRuntimeRep ty ++ ty) tidy_p]
 
   -- --------------------------------------------------------------------------
   -- Not supposed to happen
@@ -2543,7 +2549,7 @@ warnPmIters dflags (DsMatchContext kind loc)
     msg is = fsep [ text "Pattern match checker exceeded"
                   , parens (ppr is), text "iterations in", ctxt <> dot
                   , text "(Use -fmax-pmcheck-iterations=n"
-                  , text "to set the maximun number of iterations to n)" ]
+                  , text "to set the maximum number of iterations to n)" ]
 
     flag_i = wopt Opt_WarnOverlappingPatterns dflags
     flag_u = exhaustive dflags kind

compiler/ghc.cabal.in

@@ -508,6 +508,7 @@ Library
         TcTyClsDecls
         TcTyDecls
         TcTypeable
+        TcTypeableValidity
         TcType
         TcEvidence
         TcEvTerm

compiler/main/DriverPipeline.hs

@@ -1193,9 +1193,6 @@ runPhase (RealPhase Cmm) input_fn dflags
 -----------------------------------------------------------------------------
 -- Cc phase
 
--- we don't support preprocessing .c files (with -E) now.  Doing so introduces
--- way too many hacks, and I can't say I've ever used it anyway.
-
 runPhase (RealPhase cc_phase) input_fn dflags
    | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx]
    = do
@@ -1217,6 +1214,16 @@ runPhase (RealPhase cc_phase) input_fn dflags
               (includePathsQuote cmdline_include_paths)
         let include_paths = include_paths_quote ++ include_paths_global
 
+        -- pass -D or -optP to preprocessor when compiling foreign C files
+        -- (#16737). Doing it in this way is simpler and also enable the C
+        -- compiler to performs preprocessing and parsing in a single pass,
+        -- but it may introduce inconsistency if a different pgm_P is specified.
+        let more_preprocessor_opts = concat
+              [ ["-Xpreprocessor", i]
+              | not hcc
+              , i <- getOpts dflags opt_P
+              ]
+
         let gcc_extra_viac_flags = extraGccViaCFlags dflags
         let pic_c_flags = picCCOpts dflags
 
@@ -1226,7 +1233,7 @@ runPhase (RealPhase cc_phase) input_fn dflags
         -- hc code doesn't not #include any header files anyway, so these
         -- options aren't necessary.
         pkg_extra_cc_opts <- liftIO $
-          if cc_phase `eqPhase` HCc
+          if hcc
              then return []
              else getPackageExtraCcOpts dflags pkgs
 
@@ -1317,6 +1324,7 @@ runPhase (RealPhase cc_phase) input_fn dflags
                        ++ [ "-include", ghcVersionH ]
                        ++ framework_paths
                        ++ include_paths
+                       ++ more_preprocessor_opts
                        ++ pkg_extra_cc_opts
                        ))
 

compiler/main/HscMain.hs

@@ -507,7 +507,9 @@ tcRnModule' sum save_rn_syntax mod = do
                  safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
                  when safe $ do
                    case wopt Opt_WarnSafe dflags of
-                     True -> (logWarnings $ unitBag $
+                     True
+                       | safeHaskell dflags == Sf_Safe -> return ()
+                       | otherwise -> (logWarnings $ unitBag $
                               makeIntoWarning (Reason Opt_WarnSafe) $
                               mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $
                               errSafe tcg_res')

compiler/main/TidyPgm.hs

@@ -7,7 +7,7 @@
 {-# LANGUAGE CPP, ViewPatterns #-}
 
 module TidyPgm (
-       mkBootModDetailsTc, tidyProgram, globaliseAndTidyId
+       mkBootModDetailsTc, tidyProgram
    ) where
 
 #include "HsVersions.h"
@@ -39,13 +39,11 @@ import Id
 import MkId             ( mkDictSelRhs )
 import IdInfo
 import InstEnv
-import FamInstEnv
 import Type             ( tidyTopType )
 import Demand           ( appIsBottom, isTopSig, isBottomingSig )
 import BasicTypes
 import Name hiding (varName)
 import NameSet
-import NameEnv
 import NameCache
 import Avail
 import IfaceEnv
@@ -60,6 +58,7 @@ import HscTypes
 import Maybes
 import UniqSupply
 import Outputable
+import Util( filterOut )
 import qualified ErrUtils as Err
 
 import Control.Monad
@@ -135,78 +134,92 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small
 
 mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails
 mkBootModDetailsTc hsc_env
-        TcGblEnv{ tcg_exports   = exports,
-                  tcg_type_env  = type_env, -- just for the Ids
-                  tcg_tcs       = tcs,
-                  tcg_patsyns   = pat_syns,
-                  tcg_insts     = insts,
-                  tcg_fam_insts = fam_insts,
-                  tcg_mod       = this_mod
+        TcGblEnv{ tcg_exports          = exports,
+                  tcg_type_env         = type_env, -- just for the Ids
+                  tcg_tcs              = tcs,
+                  tcg_patsyns          = pat_syns,
+                  tcg_insts            = insts,
+                  tcg_fam_insts        = fam_insts,
+                  tcg_complete_matches = complete_sigs,
+                  tcg_mod              = this_mod
                 }
   = -- This timing isn't terribly useful since the result isn't forced, but
     -- the message is useful to locating oneself in the compilation process.
     Err.withTiming (pure dflags)
                    (text "CoreTidy"<+>brackets (ppr this_mod))
                    (const ()) $
-    do  { let { insts'     = map (tidyClsInstDFun globaliseAndTidyId) insts
-              ; pat_syns'  = map (tidyPatSynIds   globaliseAndTidyId) pat_syns
-              ; type_env1  = mkBootTypeEnv (availsToNameSet exports)
-                                           (typeEnvIds type_env) tcs fam_insts
-              ; type_env2  = extendTypeEnvWithPatSyns pat_syns' type_env1
-              ; dfun_ids   = map instanceDFunId insts'
-              ; type_env'  = extendTypeEnvWithIds type_env2 dfun_ids
-              }
-        ; return (ModDetails { md_types     = type_env'
-                             , md_insts     = insts'
-                             , md_fam_insts = fam_insts
-                             , md_rules     = []
-                             , md_anns      = []
-                             , md_exports   = exports
-                             , md_complete_sigs = []
-                             })
-        }
+    return (ModDetails { md_types         = type_env'
+                       , md_insts         = insts'
+                       , md_fam_insts     = fam_insts
+                       , md_rules         = []
+                       , md_anns          = []
+                       , md_exports       = exports
+                       , md_complete_sigs = complete_sigs
+                       })
   where
     dflags = hsc_dflags hsc_env
 
-mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv
-mkBootTypeEnv exports ids tcs fam_insts
-  = tidyTypeEnv True $
-       typeEnvFromEntities final_ids tcs fam_insts
-  where
-        -- Find the LocalIds in the type env that are exported
-        -- Make them into GlobalIds, and tidy their types
-        --
-        -- It's very important to remove the non-exported ones
-        -- because we don't tidy the OccNames, and if we don't remove
-        -- the non-exported ones we'll get many things with the
-        -- same name in the interface file, giving chaos.
-        --
-        -- Do make sure that we keep Ids that are already Global.
-        -- When typechecking an .hs-boot file, the Ids come through as
-        -- GlobalIds.
-    final_ids = [ (if isLocalId id then globaliseAndTidyId id
-                                   else id)
-                        `setIdUnfolding` BootUnfolding
-                | id <- ids
+    -- Find the LocalIds in the type env that are exported
+    -- Make them into GlobalIds, and tidy their types
+    --
+    -- It's very important to remove the non-exported ones
+    -- because we don't tidy the OccNames, and if we don't remove
+    -- the non-exported ones we'll get many things with the
+    -- same name in the interface file, giving chaos.
+    --
+    -- Do make sure that we keep Ids that are already Global.
+    -- When typechecking an .hs-boot file, the Ids come through as
+    -- GlobalIds.
+    final_ids = [ globaliseAndTidyBootId id
+                | id <- typeEnvIds type_env
                 , keep_it id ]
 
-        -- default methods have their export flag set, but everything
-        -- else doesn't (yet), because this is pre-desugaring, so we
-        -- must test both.
-    keep_it id = isExportedId id || idName id `elemNameSet` exports
-
+    final_tcs  = filterOut (isWiredInName . getName) tcs
+                 -- See Note [Drop wired-in things]
+    type_env1  = typeEnvFromEntities final_ids final_tcs fam_insts
+    insts'     = mkFinalClsInsts type_env1 insts
+    pat_syns'  = mkFinalPatSyns  type_env1 pat_syns
+    type_env'  = extendTypeEnvWithPatSyns pat_syns' type_env1
+
+    -- Default methods have their export flag set (isExportedId),
+    -- but everything else doesn't (yet), because this is
+    -- pre-desugaring, so we must test against the exports too.
+    keep_it id | isWiredInName id_name           = False
+                 -- See Note [Drop wired-in things]
+               | isExportedId id                 = True
+               | id_name `elemNameSet` exp_names = True
+               | otherwise                       = False
+               where
+                 id_name = idName id
+
+    exp_names = availsToNameSet exports
+
+lookupFinalId :: TypeEnv -> Id -> Id
+lookupFinalId type_env id
+  = case lookupTypeEnv type_env (idName id) of
+      Just (AnId id') -> id'
+      _ -> pprPanic "lookup_final_id" (ppr id)
+
+mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst]
+mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env))
+
+mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn]
+mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env))
 
+extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv
+extendTypeEnvWithPatSyns tidy_patsyns type_env
+  = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]
 
-globaliseAndTidyId :: Id -> Id
--- Takes a LocalId with an External Name,
+globaliseAndTidyBootId :: Id -> Id
+-- For a LocalId with an External Name,
 -- makes it into a GlobalId
 --     * unchanged Name (might be Internal or External)
 --     * unchanged details
---     * VanillaIdInfo (makes a conservative assumption about Caf-hood)
-globaliseAndTidyId id
-  = Id.setIdType (globaliseId id) tidy_type
-  where
-    tidy_type = tidyTopType (idType id)
+--     * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity)
+--     * BootUnfolding (see Note [Inlining and hs-boot files] in ToIface)
+globaliseAndTidyBootId id
+  = globaliseId id `setIdType`      tidyTopType (idType id)
+                   `setIdUnfolding` BootUnfolding
 
 {-
 ************************************************************************
@@ -334,13 +347,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
     do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags
               ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags
               ; print_unqual = mkPrintUnqualified dflags rdr_env
-              }
-
-        ; let { type_env = typeEnvFromEntities [] tcs fam_insts
-
-              ; implicit_binds
-                  = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++
-                    concatMap getTyConImplicitBinds (typeEnvTyCons type_env)
+              ; implicit_binds = concatMap getImplicitBinds tcs
               }
 
         ; (unfold_env, tidy_occ_env)
@@ -352,30 +359,6 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
         ; (tidy_env, tidy_binds)
                  <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds
 
-        ; let { final_ids  = [ id | id <- bindersOfBinds tidy_binds,
-                                    isExternalName (idName id)]
-              ; type_env1  = extendTypeEnvWithIds type_env final_ids
-
-              ; tidy_cls_insts = map (tidyClsInstDFun (tidyVarOcc tidy_env)) cls_insts
-                -- A DFunId will have a binding in tidy_binds, and so will now be in
-                -- tidy_type_env, replete with IdInfo.  Its name will be unchanged since
-                -- it was born, but we want Global, IdInfo-rich (or not) DFunId in the
-                -- tidy_cls_insts.  Similarly the Ids inside a PatSyn.
-
-              ; tidy_rules = tidyRules tidy_env trimmed_rules
-                -- You might worry that the tidy_env contains IdInfo-rich stuff
-                -- and indeed it does, but if omit_prags is on, ext_rules is
-                -- empty
-
-                -- Tidy the Ids inside each PatSyn, very similarly to DFunIds
-                -- and then override the PatSyns in the type_env with the new tidy ones
-                -- This is really the only reason we keep mg_patsyns at all; otherwise
-                -- they could just stay in type_env
-              ; tidy_patsyns = map (tidyPatSynIds (tidyVarOcc tidy_env)) patsyns
-              ; type_env2    = extendTypeEnvWithPatSyns tidy_patsyns type_env1
-
-              ; tidy_type_env = tidyTypeEnv omit_prags type_env2
-              }
           -- See Note [Grand plan for static forms] in StaticPtrTable.
         ; (spt_entries, tidy_binds') <-
              sptCreateStaticBinds hsc_env mod tidy_binds
@@ -387,20 +370,44 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                     HscInterpreted -> id
                     -- otherwise add a C stub to do so
                     _              -> (`appendStubC` spt_init_code)
-              }
 
-        ; let { -- See Note [Injecting implicit bindings]
+              -- The completed type environment is gotten from
+              --      a) the types and classes defined here (plus implicit things)
+              --      b) adding Ids with correct IdInfo, including unfoldings,
+              --              gotten from the bindings
+              -- From (b) we keep only those Ids with External names;
+              --          the CoreTidy pass makes sure these are all and only
+              --          the externally-accessible ones
+              -- This truncates the type environment to include only the
+              -- exported Ids and things needed from them, which saves space
+              --
+              -- See Note [Don't attempt to trim data types]
+              ; final_ids  = [ if omit_prags then trimId id else id
+                             | id <- bindersOfBinds tidy_binds
+                             , isExternalName (idName id)
+                             , not (isWiredInName (getName id))
+                             ]   -- See Note [Drop wired-in things]
+
+              ; final_tcs      = filterOut (isWiredInName . getName) tcs
+                                 -- See Note [Drop wired-in things]
+              ; type_env       = typeEnvFromEntities final_ids final_tcs fam_insts
+              ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts
+              ; tidy_patsyns   = mkFinalPatSyns  type_env patsyns
+              ; tidy_type_env  = extendTypeEnvWithPatSyns tidy_patsyns type_env
+              ; tidy_rules     = tidyRules tidy_env trimmed_rules
+
+              ; -- See Note [Injecting implicit bindings]
                 all_tidy_binds = implicit_binds ++ tidy_binds'
 
               -- Get the TyCons to generate code for.  Careful!  We must use
-              -- the untidied TypeEnv here, because we need
+              -- the untidied TyCons here, because we need
               --  (a) implicit TyCons arising from types and classes defined
               --      in this module
               --  (b) wired-in TyCons, which are normally removed from the
               --      TypeEnv we put in the ModDetails
               --  (c) Constructors even if they are not exported (the
               --      tidied TypeEnv has trimmed these away)
-              ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
+              ; alg_tycons = filter isAlgTyCon tcs
               }
 
         ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules
@@ -443,46 +450,19 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
   where
     dflags = hsc_dflags hsc_env
 
-tidyTypeEnv :: Bool       -- Compiling without -O, so omit prags
-            -> TypeEnv -> TypeEnv
-
--- The completed type environment is gotten from
---      a) the types and classes defined here (plus implicit things)
---      b) adding Ids with correct IdInfo, including unfoldings,
---              gotten from the bindings
--- From (b) we keep only those Ids with External names;
---          the CoreTidy pass makes sure these are all and only
---          the externally-accessible ones
--- This truncates the type environment to include only the
--- exported Ids and things needed from them, which saves space
---
--- See Note [Don't attempt to trim data types]
-
-tidyTypeEnv omit_prags type_env
- = let
-        type_env1 = filterNameEnv (not . isWiredInName . getName) type_env
-          -- (1) remove wired-in things
-        type_env2 | omit_prags = mapNameEnv trimThing type_env1
-                  | otherwise  = type_env1
-          -- (2) trimmed if necessary
-    in
-    type_env2
-
 --------------------------
-trimThing :: TyThing -> TyThing
--- Trim off inessentials, for boot files and no -O
-trimThing (AnId id)
-   | not (isImplicitId id)
-   = AnId (id `setIdInfo` vanillaIdInfo)
+trimId :: Id -> Id
+trimId id
+  | not (isImplicitId id)
+  = id `setIdInfo` vanillaIdInfo
+  | otherwise
+  = id
 
-trimThing other_thing
-  = other_thing
+{- Note [Drop wired-in things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We never put wired-in TyCons or Ids in an interface file.
+They are wired-in, so the compiler knows about them already.
 
-extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv
-extendTypeEnvWithPatSyns tidy_patsyns type_env
-  = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]
-
-{-
 Note [Don't attempt to trim data types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 For some time GHC tried to avoid exporting the data constructors
@@ -564,6 +544,11 @@ really just a code generation trick.... binding itself makes no sense.
 See Note [Data constructor workers] in CorePrep.
 -}
 
+getImplicitBinds :: TyCon -> [CoreBind]
+getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc
+  where
+    cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc)
+
 getTyConImplicitBinds :: TyCon -> [CoreBind]
 getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))
 

compiler/nativeGen/PPC/CodeGen.hs

@@ -943,6 +943,7 @@ condIntCode' True cond W64 x y
                  , BCC LE cmp_lo Nothing
                  , CMPL II32 x_lo (RIReg y_lo)
                  , BCC ALWAYS end_lbl Nothing
+                 , NEWBLOCK cmp_lo
                  , CMPL II32 y_lo (RIReg x_lo)
                  , BCC ALWAYS end_lbl Nothing
 

compiler/nativeGen/PPC/Instr.hs

@@ -98,7 +98,7 @@ ppc_mkStackAllocInstr' platform amount
     , STU fmt r0 (AddrRegReg sp tmp)
     ]
   where
-    fmt = intFormat $ widthFromBytes ((platformWordSize platform) `quot` 8)
+    fmt = intFormat $ widthFromBytes (platformWordSize platform)
     zero = ImmInt 0
     tmp = tmpReg platform
     immAmount = ImmInt amount

compiler/simplCore/Simplify.hs

@@ -1268,9 +1268,13 @@ simplCast env body co0 cont0
 
         addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
           | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty
+          , Pair hole_ty _ <- coercionKind co
           = {-#SCC "addCoerce-pushCoTyArg" #-}
             do { tail' <- addCoerceM m_co' tail
-               ; return (cont { sc_arg_ty = arg_ty', sc_cont = tail' }) }
+               ; return (cont { sc_arg_ty  = arg_ty'
+                              , sc_hole_ty = hole_ty  -- NB!  As the cast goes past, the
+                                                      -- type of the hole changes (#16312)
+                              , sc_cont    = tail' }) }
 
         addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se
                                       , sc_dup = dup, sc_cont = tail })

compiler/typecheck/ClsInst.hs

@@ -16,6 +16,7 @@ import TcRnMonad
 import TcType
 import TcMType
 import TcEvidence
+import TcTypeableValidity
 import RnEnv( addUsedGRE )
 import RdrName( lookupGRE_FieldLabel )
 import InstEnv
@@ -432,7 +433,7 @@ doFunTy clas ty arg_ty ret_ty
 -- of monomorphic kind (e.g. all kind variables have been instantiated).
 doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult
 doTyConApp clas ty tc kind_args
-  | Just _ <- tyConRepName_maybe tc
+  | tyConIsTypeable tc
   = return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args)
                      , cir_mk_ev     = mk_ev
                      , cir_what      = BuiltinInstance }

compiler/typecheck/TcRnDriver.hs

@@ -61,7 +61,6 @@ import RnExpr
 import RnUtils ( HsDocContext(..) )
 import RnFixity ( lookupFixityRn )
 import MkId
-import TidyPgm    ( globaliseAndTidyId )
 import TysWiredIn ( unitTy, mkListTy )
 import Plugins
 import DynFlags
@@ -2550,7 +2549,9 @@ tcRnDeclsi hsc_env local_decls
 externaliseAndTidyId :: Module -> Id -> TcM Id
 externaliseAndTidyId this_mod id
   = do { name' <- externaliseName this_mod (idName id)
-       ; return (globaliseAndTidyId (setIdName id name')) }
+       ; return $ globaliseId id
+                     `setIdName` name'
+                     `setIdType` tidyTopType (idType id) }
 
 
 {-

compiler/typecheck/TcTypeable.hs

@@ -19,6 +19,7 @@ import TyCoRep( Type(..), TyLit(..) )
 import TcEnv
 import TcEvidence ( mkWpTyApps )
 import TcRnMonad
+import TcTypeableValidity
 import HscTypes ( lookupId )
 import PrelNames
 import TysPrim ( primTyCons )
@@ -43,7 +44,6 @@ import FastString ( FastString, mkFastString, fsLit )
 
 import Control.Monad.Trans.State
 import Control.Monad.Trans.Class (lift)
-import Data.Maybe ( isJust )
 import Data.Word( Word64 )
 
 {- Note [Grand plan for Typeable]
@@ -410,36 +410,6 @@ mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..})
            tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs
        return $ unitBag tycon_rep_bind
 
--- | Here is where we define the set of Typeable types. These exclude type
--- families and polytypes.
-tyConIsTypeable :: TyCon -> Bool
-tyConIsTypeable tc =
-       isJust (tyConRepName_maybe tc)
-    && typeIsTypeable (dropForAlls $ tyConKind tc)
-      -- Ensure that the kind of the TyCon, with its initial foralls removed,
-      -- is representable (e.g. has no higher-rank polymorphism or type
-      -- synonyms).
-
--- | Is a particular 'Type' representable by @Typeable@? Here we look for
--- polytypes and types containing casts (which may be, for instance, a type
--- family).
-typeIsTypeable :: Type -> Bool
--- We handle types of the form (TYPE rep) specifically to avoid
--- looping on (tyConIsTypeable RuntimeRep)
-typeIsTypeable ty
-  | Just ty' <- coreView ty         = typeIsTypeable ty'
-typeIsTypeable ty
-  | isJust (kindRep_maybe ty)       = True
-typeIsTypeable (TyVarTy _)          = True
-typeIsTypeable (AppTy a b)          = typeIsTypeable a && typeIsTypeable b
-typeIsTypeable (FunTy a b)          = typeIsTypeable a && typeIsTypeable b
-typeIsTypeable (TyConApp tc args)   = tyConIsTypeable tc
-                                   && all typeIsTypeable args
-typeIsTypeable (ForAllTy{})         = False
-typeIsTypeable (LitTy _)            = True
-typeIsTypeable (CastTy{})           = False
-typeIsTypeable (CoercionTy{})       = False
-
 -- | Maps kinds to 'KindRep' bindings. This binding may either be defined in
 -- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing')
 -- or a binding which we generated in the current module (in which case it will

compiler/typecheck/TcTypeableValidity.hs

+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1999
+-}
+
+-- | This module is separate from "TcTypeable" because the functions in this
+-- module are used in "ClsInst", and importing "TcTypeable" from "ClsInst"
+-- would lead to an import cycle.
+module TcTypeableValidity (tyConIsTypeable, typeIsTypeable) where
+
+import GhcPrelude
+
+import TyCoRep
+import TyCon
+import Type
+
+import Data.Maybe (isJust)
+
+-- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type
+-- families and polytypes.
+tyConIsTypeable :: TyCon -> Bool
+tyConIsTypeable tc =
+       isJust (tyConRepName_maybe tc)
+    && typeIsTypeable (dropForAlls $ tyConKind tc)
+
+-- | Is a particular 'Type' representable by @Typeable@? Here we look for
+-- polytypes and types containing casts (which may be, for instance, a type
+-- family).
+typeIsTypeable :: Type -> Bool
+-- We handle types of the form (TYPE LiftedRep) specifically to avoid
+-- looping on (tyConIsTypeable RuntimeRep). We used to consider (TYPE rr)
+-- to be typeable without inspecting rr, but this exhibits bad behavior
+-- when rr is a type family.
+typeIsTypeable ty
+  | Just ty' <- coreView ty         = typeIsTypeable ty'
+typeIsTypeable ty
+  | isLiftedTypeKind ty             = True
+typeIsTypeable (TyVarTy _)          = True
+typeIsTypeable (AppTy a b)          = typeIsTypeable a && typeIsTypeable b
+typeIsTypeable (FunTy _ a b)        = typeIsTypeable a && typeIsTypeable b
+typeIsTypeable (TyConApp tc args)   = tyConIsTypeable tc
+                                   && all typeIsTypeable args
+typeIsTypeable (ForAllTy{})         = False
+typeIsTypeable (LitTy _)            = True
+typeIsTypeable (CastTy{})           = False
+typeIsTypeable (CoercionTy{})       = False

compiler/types/InstEnv.hs

@@ -14,7 +14,7 @@ module InstEnv (
         OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
         ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,
         instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,
-        instanceDFunId, tidyClsInstDFun, instanceRoughTcs,
+        instanceDFunId, updateClsInstDFun, instanceRoughTcs,
         fuzzyClsInstCmp, orphNamesOfClsInst,
 
         InstEnvs(..), VisibleOrphanModules, InstEnv,
@@ -199,8 +199,8 @@ being equal to
 instanceDFunId :: ClsInst -> DFunId
 instanceDFunId = is_dfun
 
-tidyClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst
-tidyClsInstDFun tidy_dfun ispec
+updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst
+updateClsInstDFun tidy_dfun ispec
   = ispec { is_dfun = tidy_dfun (is_dfun ispec) }
 
 instanceRoughTcs :: ClsInst -> [Maybe Name]

compiler/types/TyCoRep.hs

@@ -2499,39 +2499,29 @@ unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2)
 
 -- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming
 -- environment. No CoVars, please!
-zipTvSubst :: [TyVar] -> [Type] -> TCvSubst
+zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst
 zipTvSubst tvs tys
-  | debugIsOn
-  , not (all isTyVar tvs) || neLength tvs tys
-  = pprTrace "zipTvSubst" (ppr tvs $$ ppr tys) emptyTCvSubst
-  | otherwise
   = mkTvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) tenv
   where
     tenv = zipTyEnv tvs tys
 
 -- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming
 -- environment.  No TyVars, please!
-zipCvSubst :: [CoVar] -> [Coercion] -> TCvSubst
+zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst
 zipCvSubst cvs cos
-  | debugIsOn
-  , not (all isCoVar cvs) || neLength cvs cos
-  = pprTrace "zipCvSubst" (ppr cvs $$ ppr cos) emptyTCvSubst
-  | otherwise
   = TCvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv cenv
   where
     cenv = zipCoEnv cvs cos
 
-zipTCvSubst :: [TyCoVar] -> [Type] -> TCvSubst
+zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst
 zipTCvSubst tcvs tys
-  | debugIsOn
-  , neLength tcvs tys
-  = pprTrace "zipTCvSubst" (ppr tcvs $$ ppr tys) emptyTCvSubst
-  | otherwise
   = zip_tcvsubst tcvs tys (mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes tys))
   where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst
         zip_tcvsubst (tv:tvs) (ty:tys) subst
           = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty)
-        zip_tcvsubst _ _ subst = subst -- empty case
+        zip_tcvsubst [] [] subst = subst -- empty case
+        zip_tcvsubst _  _  _     = pprPanic "zipTCvSubst: length mismatch"
+                                            (ppr tcvs <+> ppr tys)
 
 -- | Generates the in-scope set for the 'TCvSubst' from the types in the
 -- incoming environment. No CoVars, please!
@@ -2545,8 +2535,12 @@ mkTvSubstPrs prs =
           and [ isTyVar tv && not (isCoercionTy ty)
               | (tv, ty) <- prs ]
 
-zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv
+zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv
 zipTyEnv tyvars tys
+  | debugIsOn
+  , not (all isTyVar tyvars)
+  = pprPanic "zipTyEnv" (ppr tyvars <+> ppr tys)
+  | otherwise
   = ASSERT( all (not . isCoercionTy) tys )
     mkVarEnv (zipEqual "zipTyEnv" tyvars tys)
         -- There used to be a special case for when
@@ -2562,8 +2556,13 @@ zipTyEnv tyvars tys
         --
         -- Simplest fix is to nuke the "optimisation"
 
-zipCoEnv :: [CoVar] -> [Coercion] -> CvSubstEnv
-zipCoEnv cvs cos = mkVarEnv (zipEqual "zipCoEnv" cvs cos)
+zipCoEnv :: HasDebugCallStack => [CoVar] -> [Coercion] -> CvSubstEnv
+zipCoEnv cvs cos
+  | debugIsOn
+  , not (all isCoVar cvs)
+  = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos)
+  | otherwise
+  = mkVarEnv (zipEqual "zipCoEnv" cvs cos)
 
 instance Outputable TCvSubst where
   ppr (TCvSubst ins tenv cenv)

compiler/types/TyCon.hs

@@ -359,13 +359,27 @@ Note [Unboxed tuple RuntimeRep vars]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The contents of an unboxed tuple may have any representation. Accordingly,
 the kind of the unboxed tuple constructor is runtime-representation
-polymorphic. For example,
+polymorphic.
+
+Type constructor (2 kind arguments)
+   (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep).
+                   TYPE q -> TYPE r -> TYPE (TupleRep [q, r])
+Data constructor (4 type arguments)
+   (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep)
+                   (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #)
+
+These extra tyvars (q and r) cause some delicate processing around tuples,
+where we need to manually insert RuntimeRep arguments.
+The same situation happens with unboxed sums: each alternative
+has its own RuntimeRep.
+For boxed tuples, there is no levity polymorphism, and therefore
+we add RuntimeReps only for the unboxed version.
+
+Type constructor (no kind arguments)
+   (,) :: Type -> Type -> Type
+Data constructor (2 type arguments)
+   (,) :: forall a b. a -> b -> (a, b)
 
-   (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). TYPE q -> TYPE r -> #
-
-These extra tyvars (v and w) cause some delicate processing around tuples,
-where we used to be able to assume that the tycon arity and the
-datacon arity were the same.
 
 Note [Injective type families]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~