Compare revisions

7c22ec68 · 1bf47fdd · 967d234a · 86c3da7c · 12853f4d · 65d05d73
--- a/.gitmodules
+++ b/.gitmodules
 [submodule "libraries/binary"]
 	path = libraries/binary
-	url = http://git.haskell.org/packages/binary.git
+	url = ../packages/binary.git
 	ignore = untracked
 [submodule "libraries/bytestring"]
 	path = libraries/bytestring
-	url = http://git.haskell.org/packages/bytestring.git
+	url = ../packages/bytestring.git
 	ignore = untracked
 [submodule "libraries/Cabal"]
 	path = libraries/Cabal
-	url = http://git.haskell.org/packages/Cabal.git
+	url = ../packages/Cabal.git
 	ignore = untracked
 [submodule "libraries/containers"]
 	path = libraries/containers
-	url = http://git.haskell.org/packages/containers.git
+	url = ../packages/containers.git
 	ignore = untracked
 [submodule "libraries/haskeline"]
 	path = libraries/haskeline
-	url = http://git.haskell.org/packages/haskeline.git
+	url = ../packages/haskeline.git
 	ignore = untracked
 [submodule "libraries/pretty"]
 	path = libraries/pretty
-	url = http://git.haskell.org/packages/pretty.git
+	url = ../packages/pretty.git
 	ignore = untracked
 [submodule "libraries/terminfo"]
 	path = libraries/terminfo
-	url = http://git.haskell.org/packages/terminfo.git
+	url = ../packages/terminfo.git
 	ignore = untracked
 [submodule "libraries/transformers"]
 	path = libraries/transformers
-	url = http://git.haskell.org/packages/transformers.git
+	url = ../packages/transformers.git
 	ignore = untracked
 [submodule "libraries/xhtml"]
 	path = libraries/xhtml
-	url = http://git.haskell.org/packages/xhtml.git
+	url = ../packages/xhtml.git
 	ignore = untracked
 [submodule "libraries/Win32"]
 	path = libraries/Win32
-	url = http://git.haskell.org/packages/Win32.git
+	url = ../packages/Win32.git
 	ignore = untracked
 [submodule "libraries/primitive"]
 	path = libraries/primitive
-	url = http://git.haskell.org/packages/primitive.git
+	url = ../packages/primitive.git
 	ignore = untracked
 [submodule "libraries/vector"]
 	path = libraries/vector
-	url = http://git.haskell.org/packages/vector.git
+	url = ../packages/vector.git
 	ignore = untracked
 [submodule "libraries/time"]
 	path = libraries/time
-	url = http://git.haskell.org/packages/time.git
+	url = ../packages/time.git
 	ignore = untracked
 [submodule "libraries/random"]
 	path = libraries/random
-	url = http://git.haskell.org/packages/random.git
+	url = ../packages/random.git
 	ignore = untracked
--- a/ANNOUNCE
+++ b/ANNOUNCE
   ==============================================================
-    The (Interactive) Glasgow Haskell Compiler -- version 6.10.1
+    The (Interactive) Glasgow Haskell Compiler -- version 7.8.2
   ==============================================================
-The GHC Team is pleased to announce a new major release of GHC. There
+The GHC Team is pleased to announce a new patchlevel release of GHC, 7.8.2.
-have been a number of significant changes since the last major release,
-including:
- * Some new language features have been implemented:
+This is a bugfix release relative to 7.8.1, so we recommend upgrading.
-   * Record syntax: wild-card patterns, punning, and field disambiguation
-   * Generalised quasi-quotes
-   * Generalised list comprehensions
-   * View patterns
- * Type families have been completely re-implemented
- * Now comes with Haddock 2, which supports all GHC extensions
- * Parallel garbage collection
- * Base provides extensible exceptions
- * The GHC API is easier to use
- * External core (output only) now works again
- * Data Parallel Haskell (DPH) comes as part of GHC
 The full release notes are here:
-  http://haskell.org/ghc/docs/6.10.1/html/users_guide/release-6-10-1.html
+  http://haskell.org/ghc/docs/7.8.1/html/users_guide/release-7-8-2.html
 How to get it
 ~~~~~~~~~~~~~
@@ -82,7 +62,8 @@ Supported Platforms
 The list of platforms we support, and the people responsible for them,
 is here:
-   http://ghc.haskell.org/trac/ghc/wiki/Contributors
+   http://ghc.haskell.org/trac/ghc/wiki/Platforms
+   http://ghc.haskell.org/trac/ghc/wiki/CodeOwners
 Ports to other platforms are possible with varying degrees of
 difficulty.  The Building Guide describes how to go about porting to a

--- a/Makefile
+++ b/Makefile
@@ -72,7 +72,7 @@ endif
 	$(MAKE) -r --no-print-directory -f ghc.mk phase=final $@
 binary-dist: binary-dist-prep
-	mv bindistprep/*.tar.bz2 .
+	mv bindistprep/*.tar.$(TAR_COMP_EXT) .
 binary-dist-prep:
 ifeq "$(mingw32_TARGET_OS)" "1"

--- a/aclocal.m4
+++ b/aclocal.m4
@@ -206,7 +206,7 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
        mipsel)
            test -z "[$]2" || eval "[$]2=ArchMipsel"
            ;;
-        hppa|hppa1_1|ia64|m68k|rs6000|s390|s390x|sparc64|vax)
+        hppa|hppa1_1|ia64|m68k|powerpc64le|rs6000|s390|s390x|sparc64|vax)
            test -z "[$]2" || eval "[$]2=ArchUnknown"
            ;;
        *)
@@ -451,6 +451,7 @@ AC_DEFUN([FP_SETTINGS],
    then
        mingw_bin_prefix=mingw/bin/
        SettingsCCompilerCommand="\$topdir/../${mingw_bin_prefix}gcc.exe"
+        SettingsHaskellCPPCommand="\$topdir/../${mingw_bin_prefix}gcc.exe"
        SettingsLdCommand="\$topdir/../${mingw_bin_prefix}ld.exe"
        SettingsArCommand="\$topdir/../${mingw_bin_prefix}ar.exe"
        SettingsPerlCommand='$topdir/../perl/perl.exe'
@@ -459,6 +460,8 @@ AC_DEFUN([FP_SETTINGS],
        SettingsTouchCommand='$topdir/touchy.exe'
    else
        SettingsCCompilerCommand="$WhatGccIsCalled"
+        SettingsHaskellCPPCommand="$HaskellCPPCmd"
+        SettingsHaskellCPPFlags="$HaskellCPPArgs"
        SettingsLdCommand="$LdCmd"
        SettingsArCommand="$ArCmd"
        SettingsPerlCommand="$PerlCmd"
@@ -483,6 +486,8 @@ AC_DEFUN([FP_SETTINGS],
    SettingsCCompilerLinkFlags="$CONF_GCC_LINKER_OPTS_STAGE2"
    SettingsLdFlags="$CONF_LD_LINKER_OPTS_STAGE2"
    AC_SUBST(SettingsCCompilerCommand)
+    AC_SUBST(SettingsHaskellCPPCommand)
+    AC_SUBST(SettingsHaskellCPPFlags)
    AC_SUBST(SettingsCCompilerFlags)
    AC_SUBST(SettingsCCompilerLinkFlags)
    AC_SUBST(SettingsLdCommand)
@@ -643,6 +648,10 @@ AC_ARG_WITH($2,
    else
        $1=$withval
    fi
+    # Remember that we set this manually.  Used to override CC_STAGE0
+    # and friends later, if we are not cross-compiling.
+    With_$2=$withval
 ],
 [
    if test "$HostOS" != "mingw32"
@@ -685,6 +694,10 @@ AC_ARG_WITH($2,
    else
        $1=$withval
    fi
+    # Remember that we set this manually.  Used to override CC_STAGE0
+    # and friends later, if we are not cross-compiling.
+    With_$2=$withval
 ],
 [
    if test "$HostOS" != "mingw32"
@@ -695,6 +708,8 @@ AC_ARG_WITH($2,
 )
 ]) # FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL
 # FP_PROG_CONTEXT_DIFF
 # --------------------
 # Figure out how to do context diffs. Sets the output variable ContextDiffCmd.
@@ -1137,6 +1152,16 @@ AC_DEFUN([FP_PROG_AR_NEEDS_RANLIB],[
        esac
    fi
+    # workaround for AC_PROG_RANLIB which sets RANLIB to `:' when
+    # ranlib is missing on the target OS. The problem is that
+    # ghc-cabal cannot execute `:' which is a shell built-in but can
+    # execute `true' which is usually simple program supported by the
+    # OS.
+    # Fixes #8795
+    if test "$RANLIB" = ":"
+    then
+        RANLIB="true"
+    fi
    REAL_RANLIB_CMD="$RANLIB"
    if test $fp_cv_prog_ar_needs_ranlib = yes
    then
@@ -1788,7 +1813,12 @@ AC_MSG_NOTICE(Building in-tree ghc-pwd)
    dnl except we don't want to have to know what make is called. Sigh.
    rm -rf utils/ghc-pwd/dist-boot
    mkdir  utils/ghc-pwd/dist-boot
-    if ! "$WithGhc" -v0 -no-user-$GHC_PACKAGE_DB_FLAG -hidir utils/ghc-pwd/dist-boot -odir utils/ghc-pwd/dist-boot -stubdir utils/ghc-pwd/dist-boot --make utils/ghc-pwd/Main.hs -o utils/ghc-pwd/dist-boot/ghc-pwd
+    dnl If special linker flags are needed to build things, then allow
+    dnl the user to pass them in via LDFLAGS.
+    changequote(, )dnl
+    GHC_LDFLAGS=`echo $LDFLAGS | sed 's/\(^\| \)\([^ ]\)/\1-optl\2/g'`
+    changequote([, ])dnl
+    if ! "$WithGhc" $GHC_LDFLAGS -v0 -no-user-$GHC_PACKAGE_DB_FLAG -hidir utils/ghc-pwd/dist-boot -odir utils/ghc-pwd/dist-boot -stubdir utils/ghc-pwd/dist-boot --make utils/ghc-pwd/Main.hs -o utils/ghc-pwd/dist-boot/ghc-pwd
    then
        AC_MSG_ERROR([Building ghc-pwd failed])
    fi
@@ -1861,6 +1891,9 @@ case "$1" in
  mips*)
    $2="mips"
    ;;
+  powerpc64le*)
+    $2="powerpc64le"
+    ;;
  powerpc64*)
    $2="powerpc64"
    ;;
@@ -2048,7 +2081,8 @@ AC_DEFUN([FIND_GCC],[
        $1="$CC"
    else
        FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL([$1], [$2], [$3])
-        # From Xcode 5 on, OS X command line tools do not include gcc anymore. Use clang.
+        # From Xcode 5 on, OS X command line tools do not include gcc
+        # anymore. Use clang.
        if test -z "$$1"
        then
            FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL([$1], [clang], [clang])
@@ -2061,4 +2095,13 @@ AC_DEFUN([FIND_GCC],[
    AC_SUBST($1)
 ])
+AC_DEFUN([MAYBE_OVERRIDE_STAGE0],[
+  if test ! -z "$With_$1" -a "$CrossCompiling" != "YES"; then
+      AC_MSG_NOTICE([Not cross-compiling, so --with-$1 also sets $2])
+      $2=$With_$1
+  fi
+])
 # LocalWords:  fi
--- a/bindisttest/Makefile
+++ b/bindisttest/Makefile
@@ -21,9 +21,9 @@ include $(TOP)/mk/tree.mk
 include $(TOP)/mk/config.mk
 ifeq "$(TEST_PREP)" "YES"
-BIN_DIST_TEST_TAR_BZ2 = ../$(BIN_DIST_PREP_TAR_BZ2)
+BIN_DIST_TEST_TAR_COMP = ../$(BIN_DIST_PREP_TAR_COMP)
 else
-BIN_DIST_TEST_TAR_BZ2 = ../$(BIN_DIST_TAR_BZ2)
+BIN_DIST_TEST_TAR_COMP = ../$(BIN_DIST_TAR_COMP)
 endif
 all:
@@ -36,7 +36,7 @@ all:
 # NB. tar has funny interpretation of filenames sometimes (thinking
 # c:/foo is a remote file), so it's safer to bzip and then pipe into
 # tar rather than using tar -xjf:
-	cd a/b/c/ && $(BZIP2_CMD) -cd ../../../$(BIN_DIST_TEST_TAR_BZ2) | $(TAR_CMD) -xf -
+	cd a/b/c/ && $(TAR_COMP_CMD) -cd ../../../$(BIN_DIST_TEST_TAR_COMP) | $(TAR_CMD) -xf -
 ifeq "$(Windows)" "YES"
 	mv a/b/c/$(BIN_DIST_NAME) $(BIN_DIST_INST_DIR)
 else

--- a/bindisttest/ghc.mk
+++ b/bindisttest/ghc.mk
@@ -11,9 +11,9 @@
 # -----------------------------------------------------------------------------
 ifeq "$(TEST_PREP)" "YES"
-BIN_DIST_TEST_TAR_BZ2 = $(BIN_DIST_PREP_TAR_BZ2)
+BIN_DIST_TEST_TAR_COMP = $(BIN_DIST_PREP_TAR_COMP)
 else
-BIN_DIST_TEST_TAR_BZ2 = $(BIN_DIST_TAR_BZ2)
+BIN_DIST_TEST_TAR_COMP = $(BIN_DIST_TAR_COMP)
 endif
 .PHONY: test_bindist
@@ -33,7 +33,7 @@ test_bindist:
 	mkdir bindisttest/a
 	mkdir bindisttest/a/b
 	mkdir bindisttest/a/b/c
-	cd bindisttest/a/b/c/ && $(BZIP2_CMD) -cd ../../../../$(BIN_DIST_TEST_TAR_BZ2) | $(TAR_CMD) -xf -
+	cd bindisttest/a/b/c/ && $(TAR_COMP_CMD) -cd ../../../../$(BIN_DIST_TEST_TAR_COMP) | $(TAR_CMD) -xf -
 	$(SHELL) bindisttest/checkBinaries.sh $(ProjectVersion)
 ifeq "$(Windows_Host)" "YES"
 	mv bindisttest/a/b/c/$(BIN_DIST_NAME) $(BIN_DIST_INST_DIR)

--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -41,7 +41,7 @@ module Demand (
        deferAfterIO,
        postProcessUnsat, postProcessDmdTypeM,
-        splitProdDmd, splitProdDmd_maybe, peelCallDmd, mkCallDmd,
+        splitProdDmd_maybe, peelCallDmd, mkCallDmd,
        dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig,
        argOneShots, argsOneShots,
@@ -64,7 +64,7 @@ import BasicTypes
 import Binary
 import Maybes           ( orElse )
-import Type            ( Type )
+import Type            ( Type, isUnLiftedType )
 import TyCon           ( isNewTyCon, isClassTyCon )
 import DataCon         ( splitDataProductType_maybe )
 \end{code}
@@ -198,11 +198,13 @@ seqMaybeStr Lazy    = ()
 seqMaybeStr (Str s) = seqStrDmd s
 -- Splitting polymorphic demands
-splitStrProdDmd :: Int -> StrDmd -> [MaybeStr]
+splitStrProdDmd :: Int -> StrDmd -> Maybe [MaybeStr]
-splitStrProdDmd n HyperStr     = replicate n strBot
+splitStrProdDmd n HyperStr   = Just (replicate n strBot)
-splitStrProdDmd n HeadStr      = replicate n strTop
+splitStrProdDmd n HeadStr    = Just (replicate n strTop)
-splitStrProdDmd n (SProd ds)   = ASSERT( ds `lengthIs` n) ds
+splitStrProdDmd n (SProd ds) = ASSERT( ds `lengthIs` n) Just ds
-splitStrProdDmd _ d@(SCall {}) = pprPanic "attempt to prod-split strictness call demand" (ppr d)
+splitStrProdDmd _ (SCall {}) = Nothing
+      -- This can happen when the programmer uses unsafeCoerce,
+      -- and we don't then want to crash the compiler (Trac #9208)
 \end{code}
 %************************************************************************
@@ -439,11 +441,12 @@ seqMaybeUsed (Use c u)  = c `seq` seqUseDmd u
 seqMaybeUsed _          = ()
 -- Splitting polymorphic Maybe-Used demands
-splitUseProdDmd :: Int -> UseDmd -> [MaybeUsed]
+splitUseProdDmd :: Int -> UseDmd -> Maybe [MaybeUsed]
-splitUseProdDmd n Used          = replicate n useTop
+splitUseProdDmd n Used          = Just (replicate n useTop)
-splitUseProdDmd n UHead         = replicate n Abs
+splitUseProdDmd n UHead         = Just (replicate n Abs)
-splitUseProdDmd n (UProd ds)    = ASSERT2( ds `lengthIs` n, ppr n $$ ppr ds ) ds
+splitUseProdDmd n (UProd ds)    = ASSERT2( ds `lengthIs` n, text "splitUseProdDmd" $$ ppr n $$ ppr ds )
-splitUseProdDmd _ d@(UCall _ _) = pprPanic "attempt to prod-split usage call demand" (ppr d)
+                                  Just ds
+splitUseProdDmd _ (UCall _ _)   = Nothing
 \end{code}
 %************************************************************************
@@ -659,26 +662,18 @@ can be expanded to saturate a callee's arity.
 \begin{code}
-splitProdDmd :: Arity -> JointDmd -> [JointDmd]
-splitProdDmd n (JD {strd = s, absd = u})
-  = mkJointDmds (split_str s) (split_abs u)
-  where
-    split_str Lazy    = replicate n Lazy
-    split_str (Str s) = splitStrProdDmd n s
-    split_abs Abs       = replicate n Abs
-    split_abs (Use _ u) = splitUseProdDmd n u
 splitProdDmd_maybe :: JointDmd -> Maybe [JointDmd]
 -- Split a product into its components, iff there is any
 -- useful information to be extracted thereby
 -- The demand is not necessarily strict!
 splitProdDmd_maybe (JD {strd = s, absd = u})
  = case (s,u) of
-      (Str (SProd sx), Use _ u)          -> Just (mkJointDmds sx (splitUseProdDmd (length sx) u))
+      (Str (SProd sx), Use _ u)          | Just ux <- splitUseProdDmd (length sx) u
-      (Str s,          Use _ (UProd ux)) -> Just (mkJointDmds (splitStrProdDmd (length ux) s) ux)
+                                         -> Just (mkJointDmds sx ux)
-      (Lazy,           Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy)    ux)
+      (Str s,          Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s
-      _                                  -> Nothing
+                                         -> Just (mkJointDmds sx ux)
+      (Lazy,           Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)
+      _ -> Nothing
 \end{code}
 %************************************************************************
@@ -1144,13 +1139,18 @@ type DeferAndUse   -- Describes how to degrade a result type
 type DeferAndUseM = Maybe DeferAndUse
  -- Nothing <=> absent-ify the result type; it will never be used
-toCleanDmd :: Demand -> (CleanDemand, DeferAndUseM)
+toCleanDmd :: Demand -> Type -> (CleanDemand, DeferAndUseM)
-- See Note [Analyzing with lazy demand and lambdas]
+toCleanDmd (JD { strd = s, absd = u }) expr_ty
-toCleanDmd (JD { strd = s, absd = u })
  = case (s,u) of
-      (Str s', Use c u') -> (CD { sd = s',      ud = u' },   Just (False, c))
+      (Str s', Use c u') -> -- The normal case
-      (Lazy,   Use c u') -> (CD { sd = HeadStr, ud = u' },   Just (True,  c))
+                            (CD { sd = s',      ud = u' }, Just (False, c))
-      (_,      Abs)      -> (CD { sd = HeadStr, ud = Used }, Nothing)
+      (Lazy,   Use c u') -> -- See Note [Analyzing with lazy demand and lambdas]
+                            (CD { sd = HeadStr, ud = u' }, Just (True,  c))
+      (_,      Abs)  -- See Note [Analysing with absent demand]
+         | isUnLiftedType expr_ty -> (CD { sd = HeadStr, ud = Used }, Just (False, One))
+         | otherwise              -> (CD { sd = HeadStr, ud = Used }, Nothing)
 -- This is used in dmdAnalStar when post-processing
 -- a function's argument demand. So we only care about what
@@ -1325,13 +1325,13 @@ cardinality analysis of the following example:
 {-# NOINLINE build #-}
 build g = (g (:) [], g (:) [])
-h c z = build (\x -> 
+h c z = build (\x ->
-                let z1 = z ++ z 
+                let z1 = z ++ z
                 in if c
                    then \y -> x (y ++ z1)
                    else \y -> x (z1 ++ y))
-One can see that `build` assigns to `g` demand <L,C(C1(U))>. 
+One can see that `build` assigns to `g` demand <L,C(C1(U))>.
 Therefore, when analyzing the lambda `(\x -> ...)`, we
 expect each lambda \y -> ... to be annotated as "one-shot"
 one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a
@@ -1340,6 +1340,46 @@ demand <C(C(..), C(C1(U))>.
 This is achieved by, first, converting the lazy demand L into the
 strict S by the second clause of the analysis.
+Note [Analysing with absent demand]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we analyse an expression with demand <L,A>.  The "A" means
+"absent", so this expression will never be needed.  What should happen?
+There are several wrinkles:
+* We *do* want to analyse the expression regardless.
+  Reason: Note [Always analyse in virgin pass]
+  But we can post-process the results to ignore all the usage
+  demands coming back. This is done by postProcessDmdTypeM.
+* But in the case of an *unlifted type* we must be extra careful,
+  because unlifted values are evaluated even if they are not used.
+  Example (see Trac #9254):
+     f :: (() -> (# Int#, () #)) -> ()
+          -- Strictness signature is
+          --    <C(S(LS)), 1*C1(U(A,1*U()))>
+          -- I.e. calls k, but discards first component of result
+     f k = case k () of (# _, r #) -> r
+     g :: Int -> ()
+     g y = f (\n -> (# case y of I# y2 -> y2, n #))
+  Here f's strictness signature says (correctly) that it calls its
+  argument function and ignores the first component of its result.
+  This is correct in the sense that it'd be fine to (say) modify the
+  function so that always returned 0# in the first component.
+  But in function g, we *will* evaluate the 'case y of ...', because
+  it has type Int#.  So 'y' will be evaluated.  So we must record this
+  usage of 'y', else 'g' will say 'y' is absent, and will w/w so that
+  'y' is bound to an aBSENT_ERROR thunk.
+  An alternative would be to replace the 'case y of ...' with (say) 0#,
+  but I have not tried that. It's not a common situation, but it is
+  not theoretical: unsafePerformIO's implementation is very very like
+  'f' above.
 %************************************************************************
 %*                                                                      *
                     Demand signatures
@@ -1461,12 +1501,12 @@ dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res))
  | otherwise   -- Not saturated
  = nopDmdType
  where
-    go_str 0 dmd        = Just (splitStrProdDmd arity dmd)
+    go_str 0 dmd        = splitStrProdDmd arity dmd
    go_str n (SCall s') = go_str (n-1) s'
    go_str n HyperStr   = go_str (n-1) HyperStr
    go_str _ _          = Nothing
-    go_abs 0 dmd            = Just (splitUseProdDmd arity dmd)
+    go_abs 0 dmd            = splitUseProdDmd arity dmd
    go_abs n (UCall One u') = go_abs (n-1) u'
    go_abs _ _              = Nothing

--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -125,7 +125,7 @@ is right here.
 \begin{code}
 wiredInIds :: [Id]
 wiredInIds
-  =  [lazyId]
+  =  [lazyId, dollarId]
  ++ errorIds		-- Defined in MkCore
  ++ ghcPrimIds
@@ -1040,20 +1040,32 @@ another gun with which to shoot yourself in the foot.
 \begin{code}
 lazyIdName, unsafeCoerceName, nullAddrName, seqName,
   realWorldName, voidPrimIdName, coercionTokenName,
-   magicDictName, coerceName, proxyName :: Name
+   magicDictName, coerceName, proxyName, dollarName :: Name
-unsafeCoerceName  = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
+unsafeCoerceName  = mkWiredInIdName gHC_PRIM  (fsLit "unsafeCoerce#")  unsafeCoerceIdKey  unsafeCoerceId
-nullAddrName      = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#")     nullAddrIdKey      nullAddrId
+nullAddrName      = mkWiredInIdName gHC_PRIM  (fsLit "nullAddr#")      nullAddrIdKey      nullAddrId
-seqName           = mkWiredInIdName gHC_PRIM (fsLit "seq")           seqIdKey           seqId
+seqName           = mkWiredInIdName gHC_PRIM  (fsLit "seq")            seqIdKey           seqId
-realWorldName     = mkWiredInIdName gHC_PRIM (fsLit "realWorld#")    realWorldPrimIdKey realWorldPrimId
+realWorldName     = mkWiredInIdName gHC_PRIM  (fsLit "realWorld#")     realWorldPrimIdKey realWorldPrimId
-voidPrimIdName    = mkWiredInIdName gHC_PRIM (fsLit "void#")         voidPrimIdKey      voidPrimId
+voidPrimIdName    = mkWiredInIdName gHC_PRIM  (fsLit "void#")          voidPrimIdKey      voidPrimId
-lazyIdName        = mkWiredInIdName gHC_MAGIC (fsLit "lazy")         lazyIdKey           lazyId
+lazyIdName        = mkWiredInIdName gHC_MAGIC (fsLit "lazy")           lazyIdKey          lazyId
-coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId
+coercionTokenName = mkWiredInIdName gHC_PRIM  (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId
-magicDictName     = mkWiredInIdName gHC_PRIM (fsLit "magicDict")     magicDictKey magicDictId
+magicDictName     = mkWiredInIdName gHC_PRIM  (fsLit "magicDict")      magicDictKey       magicDictId
-coerceName        = mkWiredInIdName gHC_PRIM (fsLit "coerce")        coerceKey          coerceId
+coerceName        = mkWiredInIdName gHC_PRIM  (fsLit "coerce")         coerceKey          coerceId
-proxyName         = mkWiredInIdName gHC_PRIM (fsLit "proxy#")        proxyHashKey       proxyHashId
+proxyName         = mkWiredInIdName gHC_PRIM  (fsLit "proxy#")         proxyHashKey       proxyHashId
+dollarName        = mkWiredInIdName gHC_BASE  (fsLit "$")              dollarIdKey        dollarId
 \end{code}
 \begin{code}
+dollarId :: Id  -- Note [dollarId magic]
+dollarId = pcMiscPrelId dollarName ty
+             (noCafIdInfo `setUnfoldingInfo` unf)
+  where
+    fun_ty = mkFunTy alphaTy openBetaTy
+    ty     = mkForAllTys [alphaTyVar, openBetaTyVar] $
+             mkFunTy fun_ty fun_ty
+    unf    = mkInlineUnfolding (Just 2) rhs
+    [f,x]  = mkTemplateLocals [fun_ty, alphaTy]
+    rhs    = mkLams [alphaTyVar, openBetaTyVar, f, x] $
+             App (Var f) (Var x)
 ------------------------------------------------
 -- proxy# :: forall a. Proxy# a
@@ -1160,6 +1172,20 @@ coerceId = pcMiscPrelId coerceName ty info
 	  [(DataAlt coercibleDataCon, [eq], Cast (Var x) (CoVarCo eq))]
 \end{code}
+Note [dollarId magic]
+~~~~~~~~~~~~~~~~~~~~~
+The only reason that ($) is wired in is so that its type can be
+    forall (a:*, b:Open). (a->b) -> a -> b
+That is, the return type can be unboxed.  E.g. this is OK
+    foo $ True    where  foo :: Bool -> Int#
+because ($) doesn't inspect or move the result of the call to foo.
+See Trac #8739.
+There is a special typing rule for ($) in TcExpr, so the type of ($)
+isn't looked at there, BUT Lint subsequently (and rightly) complains
+if sees ($) applied to Int# (say), unless we give it a wired-in type
+as we do here.
 Note [Unsafe coerce magic]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 We define a *primitive*

--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -51,7 +51,6 @@ module OccName (
 	mkTcOcc, mkTcOccFS,
 	mkClsOcc, mkClsOccFS,
        mkDFunOcc,
-	mkTupleOcc, 
 	setOccNameSpace,
        demoteOccName,
        HasOccName(..),
@@ -82,14 +81,12 @@ module OccName (
 	isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace,
-	isTupleOcc_maybe,
 	-- * The 'OccEnv' type
 	OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv,
 	lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv,
 	occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,
        extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv,
-        alterOccEnv, 
+        alterOccEnv, pprOccEnv,
 	-- * The 'OccSet' type
 	OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, 
@@ -108,7 +105,6 @@ module OccName (
 import Util
 import Unique
-import BasicTypes
 import DynFlags
 import UniqFM
 import UniqSet
@@ -261,6 +257,11 @@ instance Data OccName where
 instance Outputable OccName where
    ppr = pprOccName
+instance OutputableBndr OccName where
+    pprBndr _ = ppr
+    pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n)
+    pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n)
 pprOccName :: OccName -> SDoc
 pprOccName (OccName sp occ) 
  = getPprStyle $ \ sty ->
@@ -415,7 +416,10 @@ filterOccEnv x (A y)       = A $ filterUFM x y
 alterOccEnv fn (A y) k     = A $ alterUFM fn y k
 instance Outputable a => Outputable (OccEnv a) where
-    ppr (A x) = ppr x
+    ppr x = pprOccEnv ppr x
+pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc
+pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env
 type OccSet = UniqSet OccName
@@ -496,7 +500,7 @@ isDataSymOcc _                    = False
 -- it is a data constructor or variable or whatever)
 isSymOcc :: OccName -> Bool
 isSymOcc (OccName DataName s)  = isLexConSym s
-isSymOcc (OccName TcClsName s) = isLexConSym s || isLexVarSym s
+isSymOcc (OccName TcClsName s) = isLexSym s
 isSymOcc (OccName VarName s)   = isLexSym s
 isSymOcc (OccName TvName s)    = isLexSym s
 -- Pretty inefficient!
@@ -805,55 +809,6 @@ tidyOccName env occ@(OccName occ_sp fs)
         new_fs = mkFastString (base ++ show n)
 \end{code}
-%************************************************************************
-%*									*
-		Stuff for dealing with tuples
-%*									*
-%************************************************************************
-\begin{code}
-mkTupleOcc :: NameSpace -> TupleSort -> Arity -> OccName
-mkTupleOcc ns sort ar = OccName ns (mkFastString str)
-  where
- 	-- no need to cache these, the caching is done in the caller
-	-- (TysWiredIn.mk_tuple)
-    str = case sort of
-		UnboxedTuple    -> '(' : '#' : commas ++ "#)"
-		BoxedTuple      -> '(' : commas ++ ")"
-                ConstraintTuple -> '(' : commas ++ ")"
-                  -- Cute hack: reuse the standard tuple OccNames (and hence code)
-                  -- for fact tuples, but give them different Uniques so they are not equal.
-                  --
-                  -- You might think that this will go wrong because isTupleOcc_maybe won't
-                  -- be able to tell the difference between boxed tuples and fact tuples. BUT:
-                  --  1. Fact tuples never occur directly in user code, so it doesn't matter
-                  --     that we can't detect them in Orig OccNames originating from the user
-                  --     programs (or those built by setRdrNameSpace used on an Exact tuple Name)
-                  --  2. Interface files have a special representation for tuple *occurrences*
-                  --     in IfaceTyCons, their workers (in IfaceSyn) and their DataCons (in case
-                  --     alternatives). Thus we don't rely on the OccName to figure out what kind
-                  --     of tuple an occurrence was trying to use in these situations.
-                  --  3. We *don't* represent tuple data type declarations specially, so those
-                  --     are still turned into wired-in names via isTupleOcc_maybe. But that's OK
-                  --     because we don't actually need to declare fact tuples thanks to this hack.
-                  --
-                  -- So basically any OccName like (,,) flowing to isTupleOcc_maybe will always
-                  -- refer to the standard boxed tuple. Cool :-)
-    commas = take (ar-1) (repeat ',')
-isTupleOcc_maybe :: OccName -> Maybe (NameSpace, TupleSort, Arity)
-- Tuples are special, because there are so many of them!
-isTupleOcc_maybe (OccName ns fs)
-  = case unpackFS fs of
-	'(':'#':',':rest     -> Just (ns, UnboxedTuple, 2 + count_commas rest)
-	'(':',':rest         -> Just (ns, BoxedTuple,   2 + count_commas rest)
-	_other               -> Nothing
-  where
-    count_commas (',':rest) = 1 + count_commas rest
-    count_commas _          = 0
-\end{code}
 %************************************************************************
 %*									*
 \subsection{Lexical categories}
@@ -863,6 +818,15 @@ isTupleOcc_maybe (OccName ns fs)
 These functions test strings to see if they fit the lexical categories
 defined in the Haskell report.
+Note [Classification of generated names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some names generated for internal use can show up in debugging output,
+e.g.  when using -ddump-simpl. These generated names start with a $
+but should still be pretty-printed using prefix notation. We make sure
+this is the case in isLexVarSym by only classifying a name as a symbol
+if all its characters are symbols, not just its first one.
 \begin{code}
 isLexCon,   isLexVar,    isLexId,    isLexSym    :: FastString -> Bool
 isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool
@@ -889,19 +853,23 @@ isLexConSym cs				-- Infix type or data constructors
  | cs == (fsLit "->") = True
  | otherwise	       = startsConSym (headFS cs)
-isLexVarSym cs				-- Infix identifiers
+isLexVarSym fs				-- Infix identifiers e.g. "+"
-  | nullFS cs	      = False		-- 	e.g. "+"
+  = case (if nullFS fs then [] else unpackFS fs) of
-  | otherwise         = startsVarSym (headFS cs)
+      [] -> False
+      (c:cs) -> startsVarSym c && all isVarSymChar cs
 -------------
 startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool
-startsVarSym c = isSymbolASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids
+startsVarSym c = isSymbolASCII c || (ord c > 0x7f && isSymbol c)  -- Infix Ids
-startsConSym c = c == ':'				-- Infix data constructors
+startsConSym c = c == ':'		-- Infix data constructors
 startsVarId c  = isLower c || c == '_'	-- Ordinary Ids
 startsConId c  = isUpper c || c == '('	-- Ordinary type constructors and data constructors
 isSymbolASCII :: Char -> Bool
 isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
+isVarSymChar :: Char -> Bool
+isVarSymChar c = c == ':' || startsVarSym c
 \end{code}
 %************************************************************************

--- a/compiler/basicTypes/PatSyn.lhs
+++ b/compiler/basicTypes/PatSyn.lhs
@@ -12,7 +12,7 @@ module PatSyn (
        -- ** Type deconstruction
        patSynId, patSynType, patSynArity, patSynIsInfix,
-        patSynArgs, patSynArgTys, patSynTyDetails,
+        patSynArgs, patSynTyDetails,
        patSynWrapper, patSynMatcher,
        patSynExTyVars, patSynSig, patSynInstArgTys
    ) where
@@ -37,8 +37,8 @@ import Data.Function
 \end{code}
-Pattern synonym representation
+Note [Pattern synonym representation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider the following pattern synonym declaration
        pattern P x = MkT [x] (Just 42)
@@ -58,15 +58,49 @@ with the following typeclass constraints:
 In this case, the fields of MkPatSyn will be set as follows:
-  psArgs       = [x :: b]
+  psArgs       = [b]
  psArity      = 1
  psInfix      = False
  psUnivTyVars = [t]
  psExTyVars   = [b]
-  psTheta      = ((Show (Maybe t), Ord b), (Eq t, Num t))
+  psProvTheta  = (Show (Maybe t), Ord b)
+  psReqTheta   = (Eq t, Num t)
  psOrigResTy  = T (Maybe t)
+Note [Matchers and wrappers for pattern synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For each pattern synonym, we generate a single matcher function which
+implements the actual matching. For the above example, the matcher
+will have type:
+        $mP :: forall r t. (Eq t, Num t)
+            => T (Maybe t)
+            -> (forall b. (Show (Maybe t), Ord b) => b -> r)
+            -> r
+            -> r
+with the following implementation:
+        $mP @r @t $dEq $dNum scrut cont fail = case scrut of
+            MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x
+            _                                 -> fail
+For *bidirectional* pattern synonyms, we also generate a single wrapper
+function which implements the pattern synonym in an expression
+context. For our running example, it will be:
+        $WP :: forall t b. (Show (Maybe t), Ord b, Eq t, Num t)
+            => b -> T (Maybe t)
+        $WP x = MkT [x] (Just 42)
+NB: the existential/universal and required/provided split does not
+apply to the wrapper since you are only putting stuff in, not getting
+stuff out.
+Injectivity of bidirectional pattern synonyms is checked in
+tcPatToExpr which walks the pattern and returns its corresponding
+expression when available.
 %************************************************************************
 %*                                                                      *
@@ -76,21 +110,36 @@ In this case, the fields of MkPatSyn will be set as follows:
 \begin{code}
 -- | A pattern synonym
+-- See Note [Pattern synonym representation]
 data PatSyn
  = MkPatSyn {
        psId          :: Id,
-        psUnique      :: Unique,                 -- Cached from Name
+        psUnique      :: Unique,      -- Cached from Name
-        psMatcher     :: Id,
-        psWrapper     :: Maybe Id,
+        psArgs        :: [Type],
+        psArity       :: Arity,       -- == length psArgs
+        psInfix       :: Bool,        -- True <=> declared infix
-        psArgs        :: [Var],
+        psUnivTyVars  :: [TyVar],     -- Universially-quantified type variables
-        psArity       :: Arity,                  -- == length psArgs
+        psExTyVars    :: [TyVar],     -- Existentially-quantified type vars
-        psInfix       :: Bool,                   -- True <=> declared infix
+        psProvTheta   :: ThetaType,   -- Provided dictionaries
+        psReqTheta    :: ThetaType,   -- Required dictionaries
+        psOrigResTy   :: Type,
-        psUnivTyVars  :: [TyVar],                -- Universially-quantified type variables
+        -- See Note [Matchers and wrappers for pattern synonyms]
-        psExTyVars    :: [TyVar],                -- Existentially-quantified type vars
+        psMatcher     :: Id,
-        psTheta       :: (ThetaType, ThetaType), -- Provided and required dictionaries
+             -- Matcher function, of type
-        psOrigResTy   :: Type
+             --   forall r univ_tvs. req_theta
+             --                   => res_ty
+             --                   -> (forall ex_tvs. prov_theta -> arg_tys -> r)
+             --                   -> r -> r
+        psWrapper     :: Maybe Id
+             -- Nothing  => uni-directional pattern synonym
+             -- Just wid => bi-direcitonal
+             -- Wrapper function, of type
+             --  forall univ_tvs, ex_tvs. (prov_theta, req_theta)
+             --                       =>  arg_tys -> res_ty
  }
  deriving Data.Typeable.Typeable
 \end{code}
@@ -144,7 +193,7 @@ instance Data.Data PatSyn where
 -- | Build a new pattern synonym
 mkPatSyn :: Name
         -> Bool       -- ^ Is the pattern synonym declared infix?
-         -> [Var]      -- ^ Original arguments
+         -> [Type]     -- ^ Original arguments
         -> [TyVar]    -- ^ Universially-quantified type variables
         -> [TyVar]    -- ^ Existentially-quantified type variables
         -> ThetaType  -- ^ Wanted dicts
@@ -160,7 +209,7 @@ mkPatSyn name declared_infix orig_args
         matcher wrapper
    = MkPatSyn {psId = id, psUnique = getUnique name,
                psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
-                psTheta = (prov_theta, req_theta),
+                psProvTheta = prov_theta, psReqTheta = req_theta,
                psInfix = declared_infix,
                psArgs = orig_args,
                psArity = length orig_args,
@@ -170,7 +219,7 @@ mkPatSyn name declared_infix orig_args
  where
    pat_ty = mkSigmaTy univ_tvs req_theta $
             mkSigmaTy ex_tvs prov_theta $
-             mkFunTys (map varType orig_args) orig_res_ty
+             mkFunTys orig_args orig_res_ty
    id = mkLocalId name pat_ty
 \end{code}
@@ -190,22 +239,21 @@ patSynIsInfix = psInfix
 patSynArity :: PatSyn -> Arity
 patSynArity = psArity
-patSynArgs :: PatSyn -> [Var]
+patSynArgs :: PatSyn -> [Type]
 patSynArgs = psArgs
-patSynArgTys :: PatSyn -> [Type]
-patSynArgTys = map varType . patSynArgs
 patSynTyDetails :: PatSyn -> HsPatSynDetails Type
-patSynTyDetails ps = case (patSynIsInfix ps, patSynArgTys ps) of
+patSynTyDetails ps = case (patSynIsInfix ps, patSynArgs ps) of
    (True, [left, right]) -> InfixPatSyn left right
    (_, tys) -> PrefixPatSyn tys
 patSynExTyVars :: PatSyn -> [TyVar]
 patSynExTyVars = psExTyVars
-patSynSig :: PatSyn -> ([TyVar], [TyVar], (ThetaType, ThetaType))
+patSynSig :: PatSyn -> ([TyVar], [TyVar], ThetaType, ThetaType)
-patSynSig ps = (psUnivTyVars ps, psExTyVars ps, psTheta ps)
+patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
+                    , psProvTheta = prov, psReqTheta = req })
+  = (univ_tvs, ex_tvs, prov, req)
 patSynWrapper :: PatSyn -> Maybe Id
 patSynWrapper = psWrapper
@@ -217,9 +265,8 @@ patSynInstArgTys :: PatSyn -> [Type] -> [Type]
 patSynInstArgTys ps inst_tys
  = ASSERT2( length tyvars == length inst_tys
          , ptext (sLit "patSynInstArgTys") <+> ppr ps $$ ppr tyvars $$ ppr inst_tys )
-    map (substTyWith tyvars inst_tys) arg_tys
+    map (substTyWith tyvars inst_tys) (psArgs ps)
  where
-    (univ_tvs, ex_tvs, _) = patSynSig ps
+    (univ_tvs, ex_tvs, _, _) = patSynSig ps
-    arg_tys = map varType (psArgs ps)
    tyvars = univ_tvs ++ ex_tvs
 \end{code}
--- a/compiler/basicTypes/RdrName.lhs
+++ b/compiler/basicTypes/RdrName.lhs
@@ -331,49 +331,71 @@ instance Ord RdrName where
 -- It is keyed by OccName, because we never use it for qualified names
 -- We keep the current mapping, *and* the set of all Names in scope
 -- Reason: see Note [Splicing Exact Names] in RnEnv
-type LocalRdrEnv = (OccEnv Name, NameSet)
+data LocalRdrEnv = LRE { lre_env      :: OccEnv Name
+                       , lre_in_scope :: NameSet }
+instance Outputable LocalRdrEnv where
+  ppr (LRE {lre_env = env, lre_in_scope = ns})
+    = hang (ptext (sLit "LocalRdrEnv {"))
+         2 (vcat [ ptext (sLit "env =") <+> pprOccEnv ppr_elt env
+                 , ptext (sLit "in_scope =") <+> braces (pprWithCommas ppr (nameSetToList ns))
+                 ] <+> char '}')
+    where
+      ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name
+                     -- So we can see if the keys line up correctly
 emptyLocalRdrEnv :: LocalRdrEnv
-emptyLocalRdrEnv = (emptyOccEnv, emptyNameSet)
+emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv, lre_in_scope = emptyNameSet }
 extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv
 -- The Name should be a non-top-level thing
-extendLocalRdrEnv (env, ns) name
+extendLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) name
  = WARN( isExternalName name, ppr name )
-    ( extendOccEnv env (nameOccName name) name
+    LRE { lre_env      = extendOccEnv env (nameOccName name) name
-    , addOneToNameSet ns name
+        , lre_in_scope = addOneToNameSet ns name }
-    )
 extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv
-extendLocalRdrEnvList (env, ns) names
+extendLocalRdrEnvList (LRE { lre_env = env, lre_in_scope = ns }) names
  = WARN( any isExternalName names, ppr names )
-    ( extendOccEnvList env [(nameOccName n, n) | n <- names]
+    LRE { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]
-    , addListToNameSet ns names
+        , lre_in_scope = addListToNameSet ns names }
-    )
 lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
-lookupLocalRdrEnv (env, _) (Unqual occ) = lookupOccEnv env occ
+lookupLocalRdrEnv (LRE { lre_env = env }) (Unqual occ) = lookupOccEnv env occ
-lookupLocalRdrEnv _        _            = Nothing
+lookupLocalRdrEnv _                       _            = Nothing
 lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name
-lookupLocalRdrOcc (env, _) occ = lookupOccEnv env occ
+lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ
 elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool
-elemLocalRdrEnv rdr_name (env, _)
+elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns })
-  | isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env
+  = case rdr_name of
-  | otherwise         = False
+      Unqual occ -> occ  `elemOccEnv` env
+      Exact name -> name `elemNameSet` ns  -- See Note [Local bindings with Exact Names]
+      Qual {} -> False
+      Orig {} -> False
 localRdrEnvElts :: LocalRdrEnv -> [Name]
-localRdrEnvElts (env, _) = occEnvElts env
+localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env
 inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool
 -- This is the point of the NameSet
-inLocalRdrEnvScope name (_, ns) = name `elemNameSet` ns
+inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns
 delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv
-delLocalRdrEnvList (env, ns) occs = (delListFromOccEnv env occs, ns)
+delLocalRdrEnvList (LRE { lre_env = env, lre_in_scope = ns }) occs 
+  = LRE { lre_env = delListFromOccEnv env occs
+        , lre_in_scope = ns }
 \end{code}
+Note [Local bindings with Exact Names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With Template Haskell we can make local bindings that have Exact Names.
+Computing shadowing etc may use elemLocalRdrEnv (at least it certainly
+does so in RnTpes.bindHsTyVars), so for an Exact Name we must consult
+the in-scope-name-set.
 %************************************************************************
 %*                                                                      *
                        GlobalRdrEnv

--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -876,6 +876,8 @@ labelDynamic dflags this_pkg this_mod lbl =
   PlainModuleInitLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageId m)
+   HpcTicksLabel m        -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageId m)
   -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
   _                 -> False
  where os = platformOS (targetPlatform dflags)

--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -450,25 +450,27 @@ in TcGenDeriv.) -}
 whether or not it has free variables, and whether we're running
 sequentially or in parallel.
-Closure                               Node   Argument   Enter
+Closure                           Node   Argument   Enter
-Characteristics                  Par   Req'd  Passing    Via
+Characteristics              Par   Req'd  Passing    Via
-------------------------------------------------------------------------------
+---------------------------------------------------------------------------
-Unknown                         & no & yes & stack      & node
+Unknown                     & no  & yes & stack     & node
-Known fun (>1 arg), no fvs      & no & no  & registers  & fast entry (enough args)
+Known fun (>1 arg), no fvs  & no  & no  & registers & fast entry (enough args)
-                                                        & slow entry (otherwise)
+                                                    & slow entry (otherwise)
-Known fun (>1 arg), fvs         & no & yes & registers  & fast entry (enough args)
+Known fun (>1 arg), fvs     & no  & yes & registers & fast entry (enough args)
-0 arg, no fvs \r,\s             & no & no  & n/a        & direct entry
+0 arg, no fvs \r,\s         & no  & no  & n/a       & direct entry
-0 arg, no fvs \u                & no & yes & n/a        & node
+0 arg, no fvs \u            & no  & yes & n/a       & node
-0 arg, fvs \r,\s                & no & yes & n/a        & direct entry
+0 arg, fvs \r,\s,selector   & no  & yes & n/a       & node
-0 arg, fvs \u                   & no & yes & n/a        & node
+0 arg, fvs \r,\s            & no  & yes & n/a       & direct entry
-Unknown                         & yes & yes & stack     & node
+0 arg, fvs \u               & no  & yes & n/a       & node
-Known fun (>1 arg), no fvs      & yes & no  & registers & fast entry (enough args)
+Unknown                     & yes & yes & stack     & node
-                                                        & slow entry (otherwise)
+Known fun (>1 arg), no fvs  & yes & no  & registers & fast entry (enough args)
-Known fun (>1 arg), fvs         & yes & yes & registers & node
+                                                    & slow entry (otherwise)
-0 arg, no fvs \r,\s             & yes & no  & n/a       & direct entry
+Known fun (>1 arg), fvs     & yes & yes & registers & node
-0 arg, no fvs \u                & yes & yes & n/a       & node
+0 arg, fvs \r,\s,selector   & yes & yes & n/a       & node
-0 arg, fvs \r,\s                & yes & yes & n/a       & node
+0 arg, no fvs \r,\s         & yes & no  & n/a       & direct entry
-0 arg, fvs \u                   & yes & yes & n/a       & node
+0 arg, no fvs \u            & yes & yes & n/a       & node
+0 arg, fvs \r,\s            & yes & yes & n/a       & node
+0 arg, fvs \u               & yes & yes & n/a       & node
 When black-holing, single-entry closures could also be entered via node
 (rather than directly) to catch double-entry. -}
@@ -519,7 +521,8 @@ getCallMethod dflags _name _ lf_info _n_args _cg_loc _self_loop_info
        -- fetched since we allocated it.
    EnterIt
-getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _cg_loc _self_loop_info
+getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _cg_loc
+              _self_loop_info
  | n_args == 0    = ASSERT( arity /= 0 )
                     ReturnIt        -- No args at all
  | n_args < arity = SlowCall        -- Not enough args
@@ -531,7 +534,8 @@ getCallMethod _ _name _ LFUnLifted n_args _cg_loc _self_loop_info
 getCallMethod _ _name _ (LFCon _) n_args _cg_loc _self_loop_info
  = ASSERT( n_args == 0 ) ReturnIt
-getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun) n_args _cg_loc _self_loop_info
+getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)
+              n_args _cg_loc _self_loop_info
  | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)
  = SlowCall    -- We cannot just enter it [in eval/apply, the entry code
                -- is the fast-entry code]
@@ -544,6 +548,12 @@ getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun) n_args
         of jumping directly to the entry code is still valid.  --SDM
        -}
  = EnterIt
+  -- even a non-updatable selector thunk can be updated by the garbage
+  -- collector, so we must enter it. (#8817)
+  | SelectorThunk{} <- std_form_info
+  = EnterIt
    -- We used to have ASSERT( n_args == 0 ), but actually it is
    -- possible for the optimiser to generate
    --   let bot :: Int = error Int "urk"
@@ -553,7 +563,8 @@ getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun) n_args
  | otherwise        -- Jump direct to code for single-entry thunks
  = ASSERT( n_args == 0 )
-    DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info updatable) 0
+    DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info
+                updatable) 0
 getCallMethod _ _name _ (LFUnknown True) _n_arg _cg_locs _self_loop_info
  = SlowCall -- might be a function
@@ -562,7 +573,8 @@ getCallMethod _ name _ (LFUnknown False) n_args _cg_loc _self_loop_info
  = ASSERT2( n_args == 0, ppr name <+> ppr n_args )
    EnterIt -- Not a function
-getCallMethod _ _name _ LFLetNoEscape _n_args (LneLoc blk_id lne_regs) _self_loop_info
+getCallMethod _ _name _ LFLetNoEscape _n_args (LneLoc blk_id lne_regs)
+              _self_loop_info
  = JumpToIt blk_id lne_regs
 getCallMethod _ _ _ _ _ _ _ = panic "Unknown call method"

--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -19,7 +19,6 @@ module CoreLint ( lintCoreBindings, lintUnfolding, lintExpr ) where
 #include "HsVersions.h"
-import Demand
 import CoreSyn
 import CoreFVs
 import CoreUtils
@@ -239,9 +238,13 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
      -- Check whether arity and demand type are consistent (only if demand analysis
      -- already happened)
-       ; checkL (case dmdTy of
+      --
-                  StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs)
+      -- Note (Apr 2014): this is actually ok.  See Note [Demand analysis for trivial right-hand sides]
-           (mkArityMsg binder)
+      --                  in DmdAnal.  After eta-expansion in CorePrep the rhs is no longer trivial.
+      --       ; let dmdTy = idStrictness binder
+      --       ; checkL (case dmdTy of
+      --                  StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs)
+      --           (mkArityMsg binder)
       ; lintIdUnfolding binder binder_ty (idUnfolding binder) }
@@ -249,7 +252,6 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
        -- the unfolding is a SimplifiableCoreExpr. Give up for now.
   where
    binder_ty                  = idType binder
-    dmdTy                      = idStrictness binder
    bndr_vars                  = varSetElems (idFreeVars binder)
    -- If you edit this function, you may need to update the GHC formalism
@@ -854,6 +856,9 @@ lintCoercion co@(TyConAppCo r tc cos)
       ; checkRole co2 r r2
       ; return (rk, mkFunTy s1 s2, mkFunTy t1 t2, r) }
+  | Just {} <- synTyConDefn_maybe tc
+  = failWithL (ptext (sLit "Synonym in TyConAppCo:") <+> ppr co)
  | otherwise
  = do { (ks,ss,ts,rs) <- mapAndUnzip4M lintCoercion cos
       ; rk <- lint_co_app co (tyConKind tc) (ss `zip` ks)
@@ -1421,6 +1426,7 @@ mkKindErrMsg tyvar arg_ty
          hang (ptext (sLit "Arg type:"))
                 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
+{- Not needed now
 mkArityMsg :: Id -> MsgDoc
 mkArityMsg binder
  = vcat [hsep [ptext (sLit "Demand type has"),
@@ -1433,7 +1439,7 @@ mkArityMsg binder
         ]
           where (StrictSig dmd_ty) = idStrictness binder
+-}
 mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc
 mkCastErr expr co from_ty expr_ty
  = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"),

--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -196,6 +196,7 @@ corePrepTopBinds initialCorePrepEnv binds
 mkDataConWorkers :: [TyCon] -> [CoreBind]
 -- See Note [Data constructor workers]
+-- c.f. Note [Injecting implicit bindings] in TidyPgm
 mkDataConWorkers data_tycons
  = [ NonRec id (Var id)        -- The ice is thin here, but it works
    | tycon <- data_tycons,     -- CorePrep will eta-expand it

--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -23,7 +23,7 @@ module CoreSubst (
 	substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
        substUnfolding, substUnfoldingSC,
 	lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc,
-        substTickish,
+        substTickish, substVarSet,
        -- ** Operations on substitutions
 	emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, 

--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -18,7 +18,7 @@ module CoreSyn (
 	-- * Main data types
        Expr(..), Alt, Bind(..), AltCon(..), Arg, Tickish(..),
        CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
-        TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
+        TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr,
        -- ** 'Expr' construction
 	mkLets, mkLams,
@@ -1106,6 +1106,25 @@ instance Outputable b => OutputableBndr (TaggedBndr b) where
  pprBndr _ b = ppr b	-- Simple
  pprInfixOcc  b = ppr b
  pprPrefixOcc b = ppr b
+deTagExpr :: TaggedExpr t -> CoreExpr
+deTagExpr (Var v)                   = Var v
+deTagExpr (Lit l)                   = Lit l
+deTagExpr (Type ty)                 = Type ty
+deTagExpr (Coercion co)             = Coercion co
+deTagExpr (App e1 e2)               = App (deTagExpr e1) (deTagExpr e2)
+deTagExpr (Lam (TB b _) e)          = Lam b (deTagExpr e)
+deTagExpr (Let bind body)           = Let (deTagBind bind) (deTagExpr body)
+deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts)
+deTagExpr (Tick t e)                = Tick t (deTagExpr e)
+deTagExpr (Cast e co)               = Cast (deTagExpr e) co
+deTagBind :: TaggedBind t -> CoreBind
+deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs)
+deTagBind (Rec prs)             = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs]
+deTagAlt :: TaggedAlt t -> CoreAlt
+deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs)
 \end{code}

--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -98,8 +98,11 @@ mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding
 mkSimpleUnfolding dflags = mkUnfolding dflags InlineRhs False False
 mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
-mkDFunUnfolding bndrs con ops 
+mkDFunUnfolding bndrs con ops
-  = DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = ops }
+  = DFunUnfolding { df_bndrs = bndrs
+                  , df_con = con
+                  , df_args = map occurAnalyseExpr ops }
+                  -- See Note [Occurrrence analysis of unfoldings]
 mkWwInlineRule :: CoreExpr -> Arity -> Unfolding
 mkWwInlineRule expr arity
@@ -143,6 +146,7 @@ mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
 -- Occurrence-analyses the expression before capturing it
 mkCoreUnfolding src top_lvl expr arity guidance 
  = CoreUnfolding { uf_tmpl   	    = occurAnalyseExpr expr,
+                      -- See Note [Occurrrence analysis of unfoldings]
    		    uf_src          = src,
    		    uf_arity        = arity,
 		    uf_is_top 	    = top_lvl,
@@ -162,6 +166,7 @@ mkUnfolding dflags src top_lvl is_bottoming expr
  = NoUnfolding    -- See Note [Do not inline top-level bottoming functions]
  | otherwise
  = CoreUnfolding { uf_tmpl   	    = occurAnalyseExpr expr,
+                      -- See Note [Occurrrence analysis of unfoldings]
    		    uf_src          = src,
    		    uf_arity        = arity,
 		    uf_is_top 	    = top_lvl,
@@ -176,6 +181,24 @@ mkUnfolding dflags src top_lvl is_bottoming expr
 	-- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
 \end{code}
+Note [Occurrence analysis of unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do occurrence-analysis of unfoldings once and for all, when the
+unfolding is built, rather than each time we inline them.
+But given this decision it's vital that we do
+*always* do it.  Consider this unfolding
+    \x -> letrec { f = ...g...; g* = f } in body
+where g* is (for some strange reason) the loop breaker.  If we don't
+occ-anal it when reading it in, we won't mark g as a loop breaker, and
+we may inline g entirely in body, dropping its binding, and leaving
+the occurrence in f out of scope. This happened in Trac #8892, where
+the unfolding in question was a DFun unfolding.
+But more generally, the simplifier is designed on the
+basis that it is looking at occurrence-analysed expressions, so better
+ensure that they acutally are.
 Note [Calculate unfolding guidance on the non-occ-anal'd expression]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Notice that we give the non-occur-analysed expression to

--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -117,7 +117,7 @@ guessSourceFile :: LHsBinds Id -> FilePath -> FilePath
 guessSourceFile binds orig_file =
     -- Try look for a file generated from a .hsc file to a
     -- .hs file, by peeking ahead.
-     let top_pos = catMaybes $ foldrBag (\ (_, (L pos _)) rest ->
+     let top_pos = catMaybes $ foldrBag (\ (L pos _) rest ->
                                 srcSpanFileName_maybe pos : rest) [] binds
     in
     case top_pos of
@@ -229,11 +229,7 @@ shouldTickPatBind density top_lev
 -- Adding ticks to bindings
 addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
-addTickLHsBinds binds = mapBagM addTick binds
+addTickLHsBinds = mapBagM addTickLHsBind
-  where
-    addTick (origin, bind) = do
-        bind' <- addTickLHsBind bind
-        return (origin, bind')
 addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
 addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,

--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -517,7 +517,7 @@ case bodies, containing the following fields:
 \begin{code}
 dsCmd ids local_vars stack_ty res_ty 
-      (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys }))
+      (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys, mg_origin = origin }))
      env_ids = do
    stack_id <- newSysLocalDs stack_ty
@@ -561,7 +561,7 @@ dsCmd ids local_vars stack_ty res_ty
        in_ty = envStackType env_ids stack_ty
    core_body <- dsExpr (HsCase exp (MG { mg_alts = matches', mg_arg_tys = arg_tys
-                                        , mg_res_ty = sum_ty }))
+                                        , mg_res_ty = sum_ty, mg_origin = origin }))
        -- Note that we replace the HsCase result type by sum_ty,
        -- which is the type of matches'
No results found