.gitlab-ci.yml

@@ -2,7 +2,7 @@ variables:
   GIT_SSL_NO_VERIFY: "1"
 
   # Commit of ghc/ci-images repository from which to pull Docker images
-  DOCKER_REV: 88e952f165f48cfb956ac9a2486a9263aa4f777c
+  DOCKER_REV: e517150438cd9df9564fb91adc4b42e2667b2bc1
 
   # Sequential version number capturing the versions of all tools fetched by
   # .gitlab/win32-init.sh.
@@ -24,9 +24,10 @@ stages:
   - full-build # Build all the things
   - cleanup    # See Note [Cleanup after the shell executor]
   - packaging  # Source distribution, etc.
-  - hackage    # head.hackage testing
+  - testing    # head.hackage correctness and compiler performance testing
   - deploy     # push documentation
 
+# N.B.Don't run on wip/ branches, instead on run on merge requests.
 .only-default: &only-default
   only:
     - master
@@ -70,10 +71,31 @@ ghc-linters:
     refs:
       - merge_requests
 
+lint-linters:
+  <<: *only-default
+  stage: lint
+  image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV"
+  script:
+    - mypy .gitlab/linters/*.py
+  dependencies: []
+  tags:
+    - lint
+
+lint-testsuite:
+  <<: *only-default
+  stage: lint
+  image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
+  script:
+    - make -Ctestsuite list_broken TEST_HC=ghc
+  dependencies: []
+  tags:
+    - lint
+
 # We allow the submodule checker to fail when run on merge requests (to
 # accomodate, e.g., haddock changes not yet upstream) but not on `master` or
 # Marge jobs.
 .lint-submods:
+  <<: *only-default
   stage: lint
   image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV"
   script:
@@ -118,6 +140,7 @@ lint-submods-branch:
       - /ghc-[0-9]+\.[0-9]+/
 
 .lint-changelogs:
+  <<: *only-default
   stage: lint
   image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV"
   dependencies: []
@@ -523,11 +546,10 @@ release-x86_64-linux-deb9-dwarf:
   extends: .validate-linux
   stage: build
   image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
-  allow_failure: true
   variables:
     CONFIGURE_ARGS: "--enable-dwarf-unwind"
     BUILD_FLAVOUR: dwarf
-    TEST_ENV: "x86_64-linux-deb9"
+    TEST_ENV: "x86_64-linux-deb9-dwarf"
   artifacts:
     when: always
     expire_in: 2 week
@@ -554,6 +576,39 @@ release-x86_64-linux-deb8:
     when: always
     expire_in: 2 week
 
+#################################
+# x86_64-linux-alpine
+#################################
+
+.build-x86_64-linux-alpine:
+  extends: .validate-linux
+  stage: full-build
+  image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-alpine:$DOCKER_REV"
+  # There are currently a few failing tests
+  allow_failure: true
+  variables:
+    BUILD_SPHINX_PDF: "NO"
+    TEST_ENV: "x86_64-linux-alpine"
+    BIN_DIST_PREP_TAR_COMP: "bindistprep/ghc-x86_64-alpine-linux.tar.xz"
+    # Can't use ld.gold due to #13958.
+    CONFIGURE_ARGS: "--disable-ld-override"
+  cache:
+    key: linux-x86_64-alpine
+  artifacts:
+    when: always
+    expire_in: 2 week
+
+release-x86_64-linux-alpine:
+  extends: .build-x86_64-linux-alpine
+  only:
+    - tags
+
+nightly-x86_64-linux-alpine:
+  extends: .build-x86_64-linux-alpine
+  only:
+    variables:
+      - $NIGHTLY
+
 #################################
 # x86_64-linux-centos7
 #################################
@@ -857,7 +912,7 @@ source-tarball:
 
 .hackage:
   <<: *only-default
-  stage: hackage
+  stage: testing
   image: ghcci/x86_64-linux-deb9:0.2
   tags:
     - x86_64-linux
@@ -883,6 +938,47 @@ nightly-hackage:
     variables:
       - $NIGHTLY
 
+############################################################
+# Nofib testing
+############################################################
+
+perf-nofib:
+  stage: testing
+  dependencies:
+    - release-x86_64-linux-deb9-dwarf
+  image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
+  only:
+    refs:
+      - merge_requests
+      - master
+      - /ghc-[0-9]+\.[0-9]+/
+  tags:
+    - x86_64-linux
+  script:
+    - root=$(pwd)/ghc
+    - |
+      mkdir tmp
+      tar -xf ghc-*-x86_64-unknown-linux.tar.xz -C tmp
+      pushd tmp/ghc-*/
+      ./configure --prefix=$root
+      make install
+      popd
+      rm -Rf tmp
+    - export BOOT_HC=$(which ghc)
+    - cabal update; cabal install -w $BOOT_HC regex-compat
+    - export PATH=$root/bin:$PATH
+    - make -C nofib boot mode=fast -j$CPUS
+    - "make -C nofib EXTRA_RUNTEST_OPTS='-cachegrind +RTS -V0 -RTS' NoFibRuns=1 mode=fast -j$CPUS 2>&1 | tee nofib.log"
+  artifacts:
+    expire_in: 12 week
+    when: always
+    paths:
+      - nofib.log
+
+############################################################
+# Documentation deployment via GitLab Pages
+############################################################
+
 pages:
   stage: deploy
   dependencies:

.gitlab/linters/check-makefiles.py

@@ -12,9 +12,10 @@ from linter import run_linters, RegexpLinter
 
 linters = [
     RegexpLinter(r'--interactive',
-                 message = "Warning: Use `$(TEST_HC_OPTS_INTERACTIVE)` instead of `--interactive -ignore-dot-ghci -v0`.",
-                 path_filter = lambda path: path == 'Makefile')
+                 message = "Warning: Use `$(TEST_HC_OPTS_INTERACTIVE)` instead of `--interactive -ignore-dot-ghci -v0`."
+                ).add_path_filter(lambda path: path.suffix == '.T')
 ]
 
 if __name__ == '__main__':
-    run_linters(linters, subdir='testsuite')
+    run_linters(linters,
+                subdir='testsuite')

.gitlab/linters/linter.py

@@ -7,10 +7,11 @@ import sys
 import re
 import textwrap
 import subprocess
-from typing import List, Optional
+from pathlib import Path
+from typing import List, Optional, Callable, Sequence
 from collections import namedtuple
 
-def lint_failure(file, line_no, line_content, message):
+def lint_failure(file, line_no: int, line_content: str, message: str):
     """ Print a lint failure message. """
     wrapper = textwrap.TextWrapper(initial_indent='  ',
                                    subsequent_indent='    ')
@@ -29,7 +30,7 @@ def lint_failure(file, line_no, line_content, message):
 
     print(textwrap.dedent(msg))
 
-def get_changed_files(base_commit, head_commit,
+def get_changed_files(base_commit: str, head_commit: str,
                       subdir: str = '.'):
     """ Get the files changed by the given range of commits. """
     cmd = ['git', 'diff', '--name-only',
@@ -46,12 +47,21 @@ class Linter(object):
     """
     def __init__(self):
         self.warnings = [] # type: List[Warning]
+        self.path_filters = [] # type: List[Callable[[Path], bool]]
 
     def add_warning(self, w: Warning):
         self.warnings.append(w)
 
-    def lint(self, path):
-        pass
+    def add_path_filter(self, f: Callable[[Path], bool]) -> "Linter":
+        self.path_filters.append(f)
+        return self
+
+    def do_lint(self, path: Path):
+        if all(f(path) for f in self.path_filters):
+            self.lint(path)
+
+    def lint(self, path: Path):
+        raise NotImplementedError
 
 class LineLinter(Linter):
     """
@@ -59,33 +69,32 @@ class LineLinter(Linter):
     the given line from a file and calls :func:`add_warning` for any lint
     issues found.
     """
-    def lint(self, path):
-        if os.path.isfile(path):
-            with open(path, 'r') as f:
+    def lint(self, path: Path):
+        if path.is_file():
+            with path.open('r') as f:
                 for line_no, line in enumerate(f):
                     self.lint_line(path, line_no+1, line)
 
-    def lint_line(self, path, line_no, line):
-        pass
+    def lint_line(self, path: Path, line_no: int, line: str):
+        raise NotImplementedError
 
 class RegexpLinter(LineLinter):
     """
     A :class:`RegexpLinter` produces the given warning message for
     all lines matching the given regular expression.
     """
-    def __init__(self, regex, message, path_filter=lambda path: True):
+    def __init__(self, regex: str, message: str):
         LineLinter.__init__(self)
         self.re = re.compile(regex)
         self.message = message
-        self.path_filter = path_filter
 
-    def lint_line(self, path, line_no, line):
-        if self.path_filter(path) and self.re.search(line):
+    def lint_line(self, path: Path, line_no: int, line: str):
+        if self.re.search(line):
             w = Warning(path=path, line_no=line_no, line_content=line[:-1],
                         message=self.message)
             self.add_warning(w)
 
-def run_linters(linters: List[Linter],
+def run_linters(linters: Sequence[Linter],
                 subdir: str = '.') -> None:
     import argparse
     parser = argparse.ArgumentParser()
@@ -97,7 +106,7 @@ def run_linters(linters: List[Linter],
         if path.startswith('.gitlab/linters'):
             continue
         for linter in linters:
-            linter.lint(path)
+            linter.do_lint(Path(path))
 
     warnings = [warning
                 for linter in linters

HACKING.md

@@ -86,10 +86,21 @@ read over this page carefully:
 
 <https://gitlab.haskell.org/ghc/ghc/wikis/building/using>
 
+A web based code explorer for the GHC source code with semantic analysis
+and type information of the GHC sources is available at:
+
+<https://haskell-code-explorer.mfix.io/>
+
+Look for `GHC` in `Package-name`. For example, here is the link to
+[GHC-8.6.5](https://haskell-code-explorer.mfix.io/package/ghc-8.6.5).
+
+
+
 If you want to watch issues and code review activities, the following page is a good start:
 
 <https://gitlab.haskell.org/ghc/ghc/activity>
 
+
 How to communicate with us
 ==========================
 

compiler/basicTypes/UniqSupply.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE BangPatterns #-}
 
 #if !defined(GHC_LOADED_INTO_GHCI)
 {-# LANGUAGE UnboxedTuples #-}
@@ -88,7 +89,7 @@ takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
 
 mkSplitUniqSupply c
   = case ord c `shiftL` uNIQUE_BITS of
-     mask -> let
+     !mask -> let
         -- here comes THE MAGIC:
 
         -- This is one of the most hammered bits in the whole compiler

compiler/cmm/CmmParse.y

@@ -198,6 +198,8 @@ necessary to the stack to accommodate it (e.g. 2).
 ----------------------------------------------------------------------------- -}
 
 {
+{-# LANGUAGE TupleSections #-}
+
 module CmmParse ( parseCmmFile ) where
 
 import GhcPrelude
@@ -808,7 +810,7 @@ foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }
         | foreign_formal ',' foreign_formals    { $1 : $3 }
 
 foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
-        : local_lreg            { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) }
+        : local_lreg            { do e <- $1; return (e, inferCmmHint (CmmReg (CmmLocal e))) }
         | STRING local_lreg     {% do h <- parseCmmHint $1;
                                       return $ do
                                          e <- $2; return (e,h) }
@@ -999,36 +1001,36 @@ machOps = listToUFM $
 callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
 callishMachOps = listToUFM $
         map (\(x, y) -> (mkFastString x, y)) [
-        ( "write_barrier", (,) MO_WriteBarrier ),
+        ( "write_barrier", (MO_WriteBarrier,)),
         ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
         ( "memset", memcpyLikeTweakArgs MO_Memset ),
         ( "memmove", memcpyLikeTweakArgs MO_Memmove ),
         ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),
 
-        ("prefetch0", (,) $ MO_Prefetch_Data 0),
-        ("prefetch1", (,) $ MO_Prefetch_Data 1),
-        ("prefetch2", (,) $ MO_Prefetch_Data 2),
-        ("prefetch3", (,) $ MO_Prefetch_Data 3),
-
-        ( "popcnt8",  (,) $ MO_PopCnt W8  ),
-        ( "popcnt16", (,) $ MO_PopCnt W16 ),
-        ( "popcnt32", (,) $ MO_PopCnt W32 ),
-        ( "popcnt64", (,) $ MO_PopCnt W64 ),
-
-        ( "pdep8",  (,) $ MO_Pdep W8  ),
-        ( "pdep16", (,) $ MO_Pdep W16 ),
-        ( "pdep32", (,) $ MO_Pdep W32 ),
-        ( "pdep64", (,) $ MO_Pdep W64 ),
-
-        ( "pext8",  (,) $ MO_Pext W8  ),
-        ( "pext16", (,) $ MO_Pext W16 ),
-        ( "pext32", (,) $ MO_Pext W32 ),
-        ( "pext64", (,) $ MO_Pext W64 ),
-
-        ( "cmpxchg8",  (,) $ MO_Cmpxchg W8  ),
-        ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ),
-        ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ),
-        ( "cmpxchg64", (,) $ MO_Cmpxchg W64 )
+        ("prefetch0", (MO_Prefetch_Data 0,)),
+        ("prefetch1", (MO_Prefetch_Data 1,)),
+        ("prefetch2", (MO_Prefetch_Data 2,)),
+        ("prefetch3", (MO_Prefetch_Data 3,)),
+
+        ( "popcnt8",  (MO_PopCnt W8,)),
+        ( "popcnt16", (MO_PopCnt W16,)),
+        ( "popcnt32", (MO_PopCnt W32,)),
+        ( "popcnt64", (MO_PopCnt W64,)),
+
+        ( "pdep8",  (MO_Pdep W8,)),
+        ( "pdep16", (MO_Pdep W16,)),
+        ( "pdep32", (MO_Pdep W32,)),
+        ( "pdep64", (MO_Pdep W64,)),
+
+        ( "pext8",  (MO_Pext W8,)),
+        ( "pext16", (MO_Pext W16,)),
+        ( "pext32", (MO_Pext W32,)),
+        ( "pext64", (MO_Pext W64,)),
+
+        ( "cmpxchg8",  (MO_Cmpxchg W8,)),
+        ( "cmpxchg16", (MO_Cmpxchg W16,)),
+        ( "cmpxchg32", (MO_Cmpxchg W32,)),
+        ( "cmpxchg64", (MO_Cmpxchg W64,))
 
         -- ToDo: the rest, maybe
         -- edit: which rest?

compiler/deSugar/Check.hs

@@ -2580,7 +2580,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

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

compiler/ghci/Linker.hs

@@ -352,8 +352,10 @@ linkCmdLineLibs' hsc_env pls =
       all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
       pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
 
+      let merged_specs = mergeStaticObjects cmdline_lib_specs
       pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
-                    cmdline_lib_specs
+                    merged_specs
+
       maybePutStr dflags "final link ... "
       ok <- resolveObjs hsc_env
 
@@ -365,6 +367,19 @@ linkCmdLineLibs' hsc_env pls =
 
       return pls1
 
+-- | Merge runs of consecutive of 'Objects'. This allows for resolution of
+-- cyclic symbol references when dynamically linking. Specifically, we link
+-- together all of the static objects into a single shared object, avoiding
+-- the issue we saw in #13786.
+mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec]
+mergeStaticObjects specs = go [] specs
+  where
+    go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec]
+    go accum (Objects objs : rest) = go (objs ++ accum) rest
+    go accum@(_:_) rest = Objects (reverse accum) : go [] rest
+    go [] (spec:rest) = spec : go [] rest
+    go [] [] = []
+
 {- Note [preload packages]
 
 Why do we need to preload packages from the command line?  This is an
@@ -392,7 +407,7 @@ users?
 
 classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec)
 classifyLdInput dflags f
-  | isObjectFilename platform f = return (Just (Object f))
+  | isObjectFilename platform f = return (Just (Objects [f]))
   | isDynLibFilename platform f = return (Just (DLLPath f))
   | otherwise          = do
         putLogMsg dflags NoReason SevInfo noSrcSpan
@@ -407,8 +422,8 @@ preloadLib
 preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
   maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
   case lib_spec of
-    Object static_ish -> do
-      (b, pls1) <- preload_static lib_paths static_ish
+    Objects static_ishs -> do
+      (b, pls1) <- preload_statics lib_paths static_ishs
       maybePutStrLn dflags (if b  then "done" else "not found")
       return pls1
 
@@ -467,13 +482,13 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
                         intercalate "\n" (map ("   "++) paths)))
 
     -- Not interested in the paths in the static case.
-    preload_static _paths name
-       = do b <- doesFileExist name
+    preload_statics _paths names
+       = do b <- or <$> mapM doesFileExist names
             if not b then return (False, pls)
                      else if dynamicGhc
-                             then  do pls1 <- dynLoadObjs hsc_env pls [name]
+                             then  do pls1 <- dynLoadObjs hsc_env pls names
                                       return (True, pls1)
-                             else  do loadObj hsc_env name
+                             else  do mapM_ (loadObj hsc_env) names
                                       return (True, pls)
 
     preload_static_archive _paths name
@@ -1139,7 +1154,9 @@ unload_wkr hsc_env keep_linkables pls@PersistentLinkerState{..}  = do
   ********************************************************************* -}
 
 data LibrarySpec
-   = Object FilePath    -- Full path name of a .o file, including trailing .o
+   = Objects [FilePath] -- Full path names of set of .o files, including trailing .o
+                        -- We allow batched loading to ensure that cyclic symbol
+                        -- references can be resolved (see #13786).
                         -- For dynamic objects only, try to find the object
                         -- file in all the directories specified in
                         -- v_Library_paths before giving up.
@@ -1173,7 +1190,7 @@ partOfGHCi
                    ["base", "template-haskell", "editline"]
 
 showLS :: LibrarySpec -> String
-showLS (Object nm)    = "(static) " ++ nm
+showLS (Objects nms)  = "(static) [" ++ intercalate ", " nms ++ "]"
 showLS (Archive nm)   = "(static archive) " ++ nm
 showLS (DLL nm)       = "(dynamic) " ++ nm
 showLS (DLLPath nm)   = "(dynamic) " ++ nm
@@ -1270,7 +1287,8 @@ linkPackage hsc_env pkg
         -- Complication: all the .so's must be loaded before any of the .o's.
         let known_dlls = [ dll  | DLLPath dll    <- classifieds ]
             dlls       = [ dll  | DLL dll        <- classifieds ]
-            objs       = [ obj  | Object obj     <- classifieds ]
+            objs       = [ obj  | Objects objs    <- classifieds
+                                , obj <- objs ]
             archs      = [ arch | Archive arch   <- classifieds ]
 
         -- Add directories to library search paths
@@ -1478,8 +1496,8 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib
                              (ArchX86_64, OSSolaris2) -> "64" </> so_name
                              _ -> so_name
 
-     findObject    = liftM (fmap Object)  $ findFile dirs obj_file
-     findDynObject = liftM (fmap Object)  $ findFile dirs dyn_obj_file
+     findObject    = liftM (fmap $ Objects . (:[]))  $ findFile dirs obj_file
+     findDynObject = liftM (fmap $ Objects . (:[]))  $ findFile dirs dyn_obj_file
      findArchive   = let local name = liftM (fmap Archive) $ findFile dirs name
                      in  apply (map local arch_files)
      findHSDll     = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file

compiler/main/DynFlags.hs

@@ -5664,10 +5664,6 @@ compilerInfo dflags
        ("Have interpreter",            showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags),
        ("Object splitting supported",  showBool False),
        ("Have native code generator",  showBool $ platformMisc_ghcWithNativeCodeGen $ platformMisc dflags),
-       ("Support SMP",                 showBool $ platformMisc_ghcWithSMP $ platformMisc dflags),
-       ("Tables next to code",         showBool $ platformMisc_tablesNextToCode $ platformMisc dflags),
-       ("RTS ways",                    platformMisc_ghcRTSWays $ platformMisc dflags),
-       ("RTS expects libdw",           showBool $ platformMisc_ghcRtsWithLibdw $ platformMisc dflags),
        -- Whether or not we support @-dynamic-too@
        ("Support dynamic-too",         showBool $ not isWindows),
        -- Whether or not we support the @-j@ flag with @--make@.
@@ -5694,7 +5690,6 @@ compilerInfo dflags
        ("GHC Dynamic",                 showBool dynamicGhc),
        -- Whether or not GHC was compiled using -prof
        ("GHC Profiled",                showBool rtsIsProfiled),
-       ("Leading underscore",          showBool $ platformMisc_leadingUnderscore $ platformMisc dflags),
        ("Debug on",                    show debugIsOn),
        ("LibDir",                      topDir dflags),
        -- The path of the global package database used by GHC

compiler/main/HscMain.hs

@@ -520,7 +520,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/rename/RnSplice.hs

@@ -378,22 +378,19 @@ mkQuasiQuoteExpr flavour quoter q_span quote
 rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars)
 -- Not exported...used for all
 rnSplice (HsTypedSplice x hasParen splice_name expr)
-  = do  { checkTH expr "Template Haskell typed splice"
-        ; loc  <- getSrcSpanM
+  = do  { loc  <- getSrcSpanM
         ; n' <- newLocalBndrRn (cL loc splice_name)
         ; (expr', fvs) <- rnLExpr expr
         ; return (HsTypedSplice x hasParen n' expr', fvs) }
 
 rnSplice (HsUntypedSplice x hasParen splice_name expr)
-  = do  { checkTH expr "Template Haskell untyped splice"
-        ; loc  <- getSrcSpanM
+  = do  { loc  <- getSrcSpanM
         ; n' <- newLocalBndrRn (cL loc splice_name)
         ; (expr', fvs) <- rnLExpr expr
         ; return (HsUntypedSplice x hasParen n' expr', fvs) }
 
 rnSplice (HsQuasiQuote x splice_name quoter q_loc quote)
-  = do  { checkTH quoter "Template Haskell quasi-quote"
-        ; loc  <- getSrcSpanM
+  = do  { loc  <- getSrcSpanM
         ; splice_name' <- newLocalBndrRn (cL loc splice_name)
 
           -- Rename the quoter; akin to the HsVar case of rnExpr

compiler/simplCore/CoreMonad.hs

@@ -36,7 +36,6 @@ module CoreMonad (
 
     -- ** Lifting into the monad
     liftIO, liftIOWithCount,
-    liftIO1, liftIO2, liftIO3, liftIO4,
 
     -- ** Dealing with annotations
     getAnnotations, getFirstAnnotations,

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/TcEvidence.hs

@@ -8,7 +8,7 @@ module TcEvidence (
   HsWrapper(..),
   (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams,
   mkWpLams, mkWpLet, mkWpCastN, mkWpCastR, collectHsWrapBinders,
-  mkWpFun, mkWpFuns, idHsWrapper, isIdHsWrapper, isErasableHsWrapper,
+  mkWpFun, idHsWrapper, isIdHsWrapper, isErasableHsWrapper,
   pprHsWrapper,
 
   -- Evidence bindings
@@ -300,21 +300,6 @@ mkWpFun (WpCast co1) WpHole       _  t2 _ = WpCast (mkTcFunCo Representational (
 mkWpFun (WpCast co1) (WpCast co2) _  _  _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2)
 mkWpFun co1          co2          t1 _  d = WpFun co1 co2 t1 d
 
--- | @mkWpFuns [(ty1, wrap1), (ty2, wrap2)] ty_res wrap_res@,
--- where @wrap1 :: ty1 "->" ty1'@ and @wrap2 :: ty2 "->" ty2'@,
--- @wrap3 :: ty3 "->" ty3'@ and @ty_res@ is /either/ @ty3@ or @ty3'@,
--- gives a wrapper @(ty1' -> ty2' -> ty3) "->" (ty1 -> ty2 -> ty3')@.
--- Notice that the result wrapper goes the other way round to all
--- the others. This is a result of sub-typing contravariance.
--- The SDoc is a description of what you were doing when you called mkWpFuns.
-mkWpFuns :: [(TcType, HsWrapper)] -> TcType -> HsWrapper -> SDoc -> HsWrapper
-mkWpFuns args res_ty res_wrap doc = snd $ go args res_ty res_wrap
-  where
-    go [] res_ty res_wrap = (res_ty, res_wrap)
-    go ((arg_ty, arg_wrap) : args) res_ty res_wrap
-      = let (tail_ty, tail_wrap) = go args res_ty res_wrap in
-        (arg_ty `mkVisFunTy` tail_ty, mkWpFun arg_wrap tail_wrap arg_ty tail_ty doc)
-
 mkWpCastR :: TcCoercionR -> HsWrapper
 mkWpCastR co
   | isTcReflCo co = WpHole

compiler/typecheck/TcRnMonad.hs

@@ -75,7 +75,6 @@ module TcRnMonad(
   askNoErrs, discardErrs, tryTcDiscardingErrs,
   checkNoErrs, whenNoErrs,
   ifErrsM, failIfErrsM,
-  checkTH, failTH,
 
   -- * Context management for the type checker
   getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
@@ -1021,17 +1020,6 @@ failIfErrsM :: TcRn ()
 -- Useful to avoid error cascades
 failIfErrsM = ifErrsM failM (return ())
 
-checkTH :: a -> String -> TcRn ()
-checkTH _ _ = return () -- OK
-
-failTH :: Outputable a => a -> String -> TcRn x
-failTH e what  -- Raise an error in a stage-1 compiler
-  = failWithTc (vcat [ hang (char 'A' <+> text what
-                             <+> text "requires GHC with interpreter support:")
-                          2 (ppr e)
-                     , text "Perhaps you are using a stage-1 compiler?" ])
-
-
 {- *********************************************************************
 *                                                                      *
         Context management for the type checker

compiler/typecheck/TcTypeable.hs

@@ -17,10 +17,11 @@ import GhcPrelude
 import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) )
 import TcBinds( addTypecheckedBinds )
 import IfaceEnv( newGlobalBinder )
-import TyCoRep( Type(..), TyLit(..), isLiftedTypeKind )
+import TyCoRep( Type(..), TyLit(..) )
 import TcEnv
 import TcEvidence ( mkWpTyApps )
 import TcRnMonad
+import TcTypeableValidity
 import HscTypes ( lookupId )
 import PrelNames
 import TysPrim ( primTyCons )
@@ -45,7 +46,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]
@@ -412,38 +412,6 @@ mkTyConRepBinds 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 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
-
 -- | 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/utils/MonadUtils.hs

@@ -8,8 +8,6 @@ module MonadUtils
         , MonadFix(..)
         , MonadIO(..)
 
-        , liftIO1, liftIO2, liftIO3, liftIO4
-
         , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM
         , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M
         , mapAccumLM
@@ -37,27 +35,6 @@ import Control.Monad.IO.Class
 import Data.Foldable (sequenceA_)
 import Data.List (unzip4, unzip5, zipWith4)
 
--------------------------------------------------------------------------------
--- Lift combinators
---  These are used throughout the compiler
--------------------------------------------------------------------------------
-
--- | Lift an 'IO' operation with 1 argument into another monad
-liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b
-liftIO1 = (.) liftIO
-
--- | Lift an 'IO' operation with 2 arguments into another monad
-liftIO2 :: MonadIO m => (a -> b -> IO c) -> a -> b -> m c
-liftIO2 = ((.).(.)) liftIO
-
--- | Lift an 'IO' operation with 3 arguments into another monad
-liftIO3 :: MonadIO m => (a -> b -> c -> IO d) -> a -> b -> c -> m d
-liftIO3 = ((.).((.).(.))) liftIO
-
--- | Lift an 'IO' operation with 4 arguments into another monad
-liftIO4 :: MonadIO m => (a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> m e
-liftIO4 = (((.).(.)).((.).(.))) liftIO
-
 -------------------------------------------------------------------------------
 -- Common functions
 --  These are used throughout the compiler

ghc.mk

@@ -1306,6 +1306,7 @@ CLEAN_FILES += includes/DerivedConstants.h
 CLEAN_FILES += includes/ghcautoconf.h
 CLEAN_FILES += includes/ghcplatform.h
 CLEAN_FILES += includes/ghcversion.h
+CLEAN_FILES += $(includes_SETTINGS)
 CLEAN_FILES += utils/ghc-pkg/Version.hs
 CLEAN_FILES += compiler/prelude/primops.txt
 CLEAN_FILES += $(wildcard compiler/primop*incl)