.gitignore

@@ -154,3 +154,11 @@ _darcs/
 .tm_properties
 VERSION
 GIT_COMMIT_ID
+
+# -------------------------------------------------------------------------------------
+# when using a docker image, one can mount the source code directory as the home folder
+# -------------------------------------------------------------------------------------
+.arcrc
+.ghc
+.bash_history
+.gitconfig

.gitmodules

@@ -10,6 +10,7 @@
 	path = libraries/Cabal
 	url = ../packages/Cabal.git
 	ignore = untracked
+	branch = 1.22
 [submodule "libraries/containers"]
 	path = libraries/containers
 	url = ../packages/containers.git
@@ -102,7 +103,7 @@
 	path = utils/haddock
 	url = ../haddock.git
 	ignore = none
-	branch = ghc-head
+	branch = master
 [submodule "nofib"]
 	path = nofib
 	url = ../nofib.git

INSTALL.md

+Building & Installing
+=====================
+
+For full information on building GHC, see the GHC Building Guide [1].
+Here follows a summary - if you get into trouble, the Building Guide
+has all the answers.
+
+Before building GHC you may need to install some other tools and
+libraries.  See "Setting up your system for building GHC" [2].
+
+NB. in particular you need GHC installed in order to build GHC,
+because the compiler is itself written in Haskell.  For instructions
+on how to port GHC to a new platform, see the Building Guide [1].
+
+For building library documentation, you'll need Haddock [3].  To build
+the compiler documentation, you need a good DocBook XML toolchain and
+dblatex.
+
+Quick start:  the following gives you a default build:
+
+    $ perl boot
+    $ ./configure
+    $ make
+    $ make install
+
+The "perl boot" step is only necessary if this is a tree checked out
+from git.  For source distributions downloaded from GHC's web site,
+this step has already been performed.
+
+These steps give you the default build, which includes everything
+optimised and built in various ways (eg. profiling libs are built).
+It can take a long time.  To customise the build, see the file
+`HACKING.md`.
+
+References
+==========
+
+ [1] http://www.haskell.org/ghc/
+ [2] http://hackage.haskell.org/trac/ghc/wiki/Building/Preparation
+ [3] http://www.haskell.org/haddock/

MAKEHELP

-
-Using the GHC build system
---------------------------
-
-For a "Getting Started" guide, see:
-
-  http://ghc.haskell.org/trac/ghc/wiki/Building/Hacking
-
-Common commands:
-
-  make
-
-     Builds everything: ghc stages 1 and 2, all libraries and tools.
-
-  make -j2
-
-     Parallel build: runs up to 2 commands at a time (use the number of
-     CPUs in your machine in place of '2')
-
-  cd <dir>; make
-
-     Builds everything in the given directory.
-
-  cd <dir>; make help
-
-     Shows the targets available in <dir>
-
-  make install
-
-     Installs GHC, libraries and tools under $(prefix)
-
-  make sdist
-  make binary-dist
-
-     Builds a source or binary distribution respectively
-
-  make show VALUE=<var>
-
-     Displays the value of make variable <var>
-
-  make clean
-  make distclean
-  make maintainer-clean
-
-     Various levels of cleaning: "clean" restores the tree to the
-     state after "./configure", "distclean" restores to the state
-     after "perl boot", and maintainer-clean restores the tree to the
-     completely clean checked-out state.
-

MAKEHELP.md

+Quick `make` guide for GHC
+==========================
+
+For a "Getting Started" guide, see:
+
+  http://ghc.haskell.org/trac/ghc/wiki/Building/Hacking
+
+Common commands:
+
+  - `make`
+
+    Builds everything: ghc stages 1 and 2, all libraries and tools.
+
+  - `make -j2`
+
+    Parallel build: runs up to 2 commands at a time.
+
+  - `cd <dir>; make`
+
+    Builds everything in the given directory.
+
+  - cd <dir>; make help
+
+    Shows the targets available in <dir>
+
+  - make install
+
+    Installs GHC, libraries and tools under $(prefix)
+
+  - make sdist
+  - make binary-dist
+
+    Builds a source or binary distribution respectively
+
+  - `make show VALUE=<var>`
+
+    Displays the value of make variable <var>
+
+  - make clean
+  - make distclean
+  - make maintainer-clean
+
+    Various levels of cleaning: "clean" restores the tree to the
+    state after "./configure", "distclean" restores to the state
+    after "perl boot", and maintainer-clean restores the tree to the
+    completely clean checked-out state.
+
+Using `make` in subdirectories
+==============================
+
+  - `make`
+
+    Builds everything in this directory (including dependencies elsewhere
+    in the tree, if necessary)
+
+  - `make fast`
+
+    The same as 'make', but omits some phases and does not
+    recalculate dependencies.  Useful for saving time if you are sure
+    the rest of the tree is up to date.
+
+  - `make clean`
+  - `make distclean`
+  - `make maintainer-clean`
+
+    Clean just this directory
+
+  - `make html`
+  - `make pdf`
+  - `make ps`
+
+    Make documentation in this directory (if any)
+
+  - `make show VALUE=var`
+
+    Show the value of $(var)
+
+  - `make <file>`
+
+    Bring a particular file up to date, e.g. make dist/build/Module.o
+    The name <file> is relative to the current directory

SUBMAKEHELP

-
-  make
-
-     Builds everything in this directory (including dependencies elsewhere
-     in the tree, if necessary)
-
-  make fast
-
-     The same as 'make', but omits some phases and does not
-     recalculate dependencies.  Useful for saving time if you are sure
-     the rest of the tree is up to date.
-
-  make clean
-  make distclean
-  make maintainer-clean
-
-     Clean just this directory
-
-  make html
-  make pdf
-  make ps
-     
-     Make documentation in this directory (if any)
-
-  make show VALUE=var
-
-     Show the value of $(var)
-
-  make <file>
-
-     Bring a particular file up to date, e.g. make dist/build/Module.o
-     The name <file> is relative to the current directory
-

aclocal.m4

@@ -565,6 +565,11 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS],
         $3="$$3 -D_HPUX_SOURCE"
         $5="$$5 -D_HPUX_SOURCE"
         ;;
+    arm*linux*)
+        # On arm/linux and arm/android, tell gcc to link using the gold linker.
+        # Forcing LD to be ld.gold is done in configre.ac.
+        $3="$$3 -fuse-ld=gold"
+        ;;
     esac
 
     # If gcc knows about the stack protector, turn it off.
@@ -1826,6 +1831,28 @@ AC_DEFUN([FP_GMP],
   AC_SUBST(GMP_LIB_DIRS)
 ])# FP_GMP
 
+# FP_CURSES
+# -------------
+AC_DEFUN([FP_CURSES],
+[
+  dnl--------------------------------------------------------------------
+  dnl * Deal with arguments telling us curses is somewhere odd
+  dnl--------------------------------------------------------------------
+
+  AC_ARG_WITH([curses-includes],
+    [AC_HELP_STRING([--with-curses-includes],
+      [directory containing curses headers])],
+      [CURSES_INCLUDE_DIRS=$withval])
+
+  AC_ARG_WITH([curses-libraries],
+    [AC_HELP_STRING([--with-curses-libraries],
+      [directory containing curses libraries])],
+      [CURSES_LIB_DIRS=$withval])
+
+  AC_SUBST(CURSES_INCLUDE_DIRS)
+  AC_SUBST(CURSES_LIB_DIRS)
+])# FP_CURSES
+
 # --------------------------------------------------------------
 # Calculate absolute path to build tree
 # --------------------------------------------------------------
@@ -2072,7 +2099,7 @@ AC_DEFUN([XCODE_VERSION],[
 #
 AC_DEFUN([FIND_LLVM_PROG],[
     FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL_NOTARGET([$1], [$2], [$3])
-    if test "$$1" == ""; then
+    if test "$$1" = ""; then
         save_IFS=$IFS
         IFS=":;"
         for p in ${PATH}; do

compiler/basicTypes/BasicTypes.hs

@@ -84,7 +84,9 @@ module BasicTypes(
 
         FractionalLit(..), negateFractionalLit, integralFractionalLit,
 
-        HValue(..)
+        HValue(..),
+
+        SourceText
    ) where
 
 import FastString
@@ -261,14 +263,15 @@ initialVersion = 1
 -}
 
 -- reason/explanation from a WARNING or DEPRECATED pragma
-data WarningTxt = WarningTxt [Located FastString]
-                | DeprecatedTxt [Located FastString]
+-- For SourceText usage, see note [Pragma source text]
+data WarningTxt = WarningTxt (Located SourceText) [Located FastString]
+                | DeprecatedTxt (Located SourceText) [Located FastString]
     deriving (Eq, Data, Typeable)
 
 instance Outputable WarningTxt where
-    ppr (WarningTxt    ws) = doubleQuotes (vcat (map (ftext . unLoc) ws))
-    ppr (DeprecatedTxt ds) = text "Deprecated:" <+>
-                             doubleQuotes (vcat (map (ftext . unLoc) ds))
+    ppr (WarningTxt    _ ws) = doubleQuotes (vcat (map (ftext . unLoc) ws))
+    ppr (DeprecatedTxt _ ds) = text "Deprecated:" <+>
+                               doubleQuotes (vcat (map (ftext . unLoc) ds))
 
 {-
 ************************************************************************
@@ -446,6 +449,15 @@ instance Outputable Origin where
 -- | The semantics allowed for overlapping instances for a particular
 -- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.lhs`) for a
 -- explanation of the `isSafeOverlap` field.
+--
+-- - 'ApiAnnotation.AnnKeywordId' :
+--      'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or
+--                              @'\{-\# OVERLAPPING'@ or
+--                              @'\{-\# OVERLAPS'@ or
+--                              @'\{-\# INCOHERENT'@,
+--      'ApiAnnotation.AnnClose' @`\#-\}`@,
+
+-- For details on above see note [Api annotations] in ApiAnnotation
 data OverlapFlag = OverlapFlag
   { overlapMode   :: OverlapMode
   , isSafeOverlap :: Bool
@@ -458,27 +470,29 @@ setOverlapModeMaybe f (Just m) = f { overlapMode = m }
 hasOverlappableFlag :: OverlapMode -> Bool
 hasOverlappableFlag mode =
   case mode of
-    Overlappable -> True
-    Overlaps     -> True
-    Incoherent   -> True
-    _            -> False
+    Overlappable _ -> True
+    Overlaps     _ -> True
+    Incoherent   _ -> True
+    _              -> False
 
 hasOverlappingFlag :: OverlapMode -> Bool
 hasOverlappingFlag mode =
   case mode of
-    Overlapping  -> True
-    Overlaps     -> True
-    Incoherent   -> True
-    _            -> False
+    Overlapping  _ -> True
+    Overlaps     _ -> True
+    Incoherent   _ -> True
+    _              -> False
 
 data OverlapMode  -- See Note [Rules for instance lookup] in InstEnv
-  = NoOverlap
+  = NoOverlap SourceText
+                  -- See Note [Pragma source text]
     -- ^ This instance must not overlap another `NoOverlap` instance.
     -- However, it may be overlapped by `Overlapping` instances,
     -- and it may overlap `Overlappable` instances.
 
 
-  | Overlappable
+  | Overlappable SourceText
+                  -- See Note [Pragma source text]
     -- ^ Silently ignore this instance if you find a
     -- more specific one that matches the constraint
     -- you are trying to resolve
@@ -492,7 +506,8 @@ data OverlapMode  -- See Note [Rules for instance lookup] in InstEnv
     -- its ambiguous which to choose)
 
 
-  | Overlapping
+  | Overlapping SourceText
+                  -- See Note [Pragma source text]
     -- ^ Silently ignore any more general instances that may be
     --   used to solve the constraint.
     --
@@ -505,10 +520,12 @@ data OverlapMode  -- See Note [Rules for instance lookup] in InstEnv
     -- it is ambiguous which to choose)
 
 
-  | Overlaps
+  | Overlaps SourceText
+                  -- See Note [Pragma source text]
     -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags.
 
-  | Incoherent
+  | Incoherent SourceText
+                  -- See Note [Pragma source text]
     -- ^ Behave like Overlappable and Overlapping, and in addition pick
     -- an an arbitrary one if there are multiple matching candidates, and
     -- don't worry about later instantiation
@@ -527,11 +544,11 @@ instance Outputable OverlapFlag where
    ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
 
 instance Outputable OverlapMode where
-   ppr NoOverlap    = empty
-   ppr Overlappable = ptext (sLit "[overlappable]")
-   ppr Overlapping  = ptext (sLit "[overlapping]")
-   ppr Overlaps     = ptext (sLit "[overlap ok]")
-   ppr Incoherent   = ptext (sLit "[incoherent]")
+   ppr (NoOverlap    _) = empty
+   ppr (Overlappable _) = ptext (sLit "[overlappable]")
+   ppr (Overlapping  _) = ptext (sLit "[overlapping]")
+   ppr (Overlaps     _) = ptext (sLit "[overlap ok]")
+   ppr (Incoherent   _) = ptext (sLit "[incoherent]")
 
 pprSafeOverlap :: Bool -> SDoc
 pprSafeOverlap True  = ptext $ sLit "[safe]"
@@ -763,6 +780,70 @@ succeeded Failed    = False
 failed Succeeded = False
 failed Failed    = True
 
+{-
+************************************************************************
+*                                                                      *
+\subsection{Source Text}
+*                                                                      *
+************************************************************************
+Keeping Source Text for source to source conversions
+
+Note [Pragma source text]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+The lexer does a case-insensitive match for pragmas, as well as
+accepting both UK and US spelling variants.
+
+So
+
+  {-# SPECIALISE #-}
+  {-# SPECIALIZE #-}
+  {-# Specialize #-}
+
+will all generate ITspec_prag token for the start of the pragma.
+
+In order to be able to do source to source conversions, the original
+source text for the token needs to be preserved, hence the
+`SourceText` field.
+
+So the lexer will then generate
+
+  ITspec_prag "{ -# SPECIALISE"
+  ITspec_prag "{ -# SPECIALIZE"
+  ITspec_prag "{ -# Specialize"
+
+for the cases above.
+ [without the space between '{' and '-', otherwise this comment won't parse]
+
+
+Note [Literal source text]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+The lexer/parser converts literals from their original source text
+versions to an appropriate internal representation. This is a problem
+for tools doing source to source conversions, so the original source
+text is stored in literals where this can occur.
+
+Motivating examples for HsLit
+
+  HsChar          '\n'       == '\x20`
+  HsCharPrim      '\x41`#    == `A`
+  HsString        "\x20\x41" == " A"
+  HsStringPrim    "\x20"#    == " "#
+  HsInt           001        == 1
+  HsIntPrim       002#       == 2#
+  HsWordPrim      003##      == 3##
+  HsInt64Prim     004##      == 4##
+  HsWord64Prim    005##      == 5##
+  HsInteger       006        == 6
+
+For OverLitVal
+
+  HsIntegral      003      == 0x003
+  HsIsString      "\x41nd" == "And"
+-}
+
+type SourceText = String -- Note [Literal source text],[Pragma source text]
+
+
 {-
 ************************************************************************
 *                                                                      *
@@ -798,7 +879,8 @@ data RuleMatchInfo = ConLike                    -- See Note [CONLIKE pragma]
 
 data InlinePragma            -- Note [InlinePragma]
   = InlinePragma
-      { inl_inline :: InlineSpec
+      { inl_src    :: SourceText -- Note [Pragma source text]
+      , inl_inline :: InlineSpec
 
       , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n
                                      --            explicit (non-type, non-dictionary) args
@@ -888,7 +970,8 @@ isEmptyInlineSpec _               = False
 
 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
   :: InlinePragma
-defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
+defaultInlinePragma = InlinePragma { inl_src = "{-# INLINE"
+                                   , inl_act = AlwaysActive
                                    , inl_rule = FunLike
                                    , inl_inline = EmptyInlineSpec
                                    , inl_sat = Nothing }

compiler/basicTypes/DataCon.hs

@@ -9,7 +9,9 @@
 
 module DataCon (
         -- * Main data types
-        DataCon, DataConRep(..), HsBang(..), StrictnessMark(..),
+        DataCon, DataConRep(..),
+        HsBang(..), HsSrcBang, HsImplBang,
+        StrictnessMark(..),
         ConTag,
 
         -- ** Type construction
@@ -26,11 +28,11 @@ module DataCon (
         dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
         dataConInstOrigArgTys, dataConRepArgTys,
         dataConFieldLabels, dataConFieldType,
-        dataConStrictMarks,
+        dataConSrcBangs,
         dataConSourceArity, dataConRepArity, dataConRepRepArity,
         dataConIsInfix,
         dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
-        dataConRepStrictness, dataConRepBangs, dataConBoxer,
+        dataConRepStrictness, dataConImplBangs, dataConBoxer,
 
         splitDataProductType_maybe,
 
@@ -248,6 +250,8 @@ Note that (Foo a) might not be an instance of Ord.
 --
 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
 --             'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma'
+
+-- For details on above see note [Api annotations] in ApiAnnotation
 data DataCon
   = MkData {
         dcName    :: Name,      -- This is the name of the *source data con*
@@ -341,9 +345,14 @@ data DataCon
                 -- The OrigResTy is T [a], but the dcRepTyCon might be :T123
 
         -- Now the strictness annotations and field labels of the constructor
-        -- See Note [Bangs on data constructor arguments]
-        dcArgBangs :: [HsBang],
-                -- Strictness annotations as decided by the compiler.
+        dcSrcBangs :: [HsBang],
+                -- See Note [Bangs on data constructor arguments]
+                -- For DataCons defined in this module: 
+                --    the [HsSrcBang] as written by the programmer.
+                -- For DataCons imported from an interface file:
+                --    the [HsImplBang] determined when compiling the
+                --    defining module
+                -- 
                 -- Matches 1-1 with dcOrigArgTys
                 -- Hence length = dataConSourceArity dataCon
 
@@ -406,9 +415,9 @@ data DataConRep
         , dcr_stricts :: [StrictnessMark]  -- 1-1 with dcr_arg_tys
                 -- See also Note [Data-con worker strictness] in MkId.lhs
 
-        , dcr_bangs :: [HsBang]  -- The actual decisions made (including failures)
-                                 -- 1-1 with orig_arg_tys
-                                 -- See Note [Bangs on data constructor arguments]
+        , dcr_bangs :: [HsImplBang]  -- The actual decisions made (including failures)
+                                     -- about the original arguments; 1-1 with orig_arg_tys
+                                     -- See Note [Bangs on data constructor arguments]
 
     }
 -- Algebraic data types always have a worker, and
@@ -437,30 +446,79 @@ data DataConRep
 -- when we bring bits of unfoldings together.)
 
 -------------------------
--- HsBang describes what the *programmer* wrote
--- This info is retained in the DataCon.dcStrictMarks field
+-- HsBang describes the strictness/unpack status of one
+-- of the original data constructor arguments (i.e. *not*
+-- of the representation data constructor which may have
+-- more arguments after the originals have been unpacked)
+-- See Note [Bangs on data constructor arguments]
 data HsBang
-  = HsUserBang   -- The user's source-code request
+  = HsNoBang     -- Equivalent to (HsSrcBang Nothing False)
+
+  | HsSrcBang    -- What the user wrote in the source code
+       (Maybe SourceText) -- Note [Pragma source text] in BasicTypes
        (Maybe Bool)       -- Just True    {-# UNPACK #-}
                           -- Just False   {-# NOUNPACK #-}
                           -- Nothing      no pragma
        Bool               -- True <=> '!' specified
+       -- (HsSrcBang (Just True) False) makes no sense
+       -- We emit a warning (in checkValidDataCon) and treat it
+       -- just like (HsSrcBang Nothing False)
 
-  | HsNoBang              -- Lazy field
-                          -- HsUserBang Nothing False means the same as HsNoBang
-
+  -- Definite implementation commitments, generated by the compiler
+  -- after consulting HsSrcBang (if any), flags, etc
   | HsUnpack              -- Definite commitment: this field is strict and unboxed
        (Maybe Coercion)   --    co :: arg-ty ~ product-ty
 
   | HsStrict              -- Definite commitment: this field is strict but not unboxed
   deriving (Data.Data, Data.Typeable)
 
+-- Two type-insecure, but useful, synonyms
+type HsSrcBang = HsBang   -- What the user wrote; hence always HsNoBang or HsSrcBang
+
+type HsImplBang = HsBang   -- A HsBang implementation decision,
+                           -- as determined by the compiler
+                           -- Never HsSrcBang
+
 -------------------------
 -- StrictnessMark is internal only, used to indicate strictness
 -- of the DataCon *worker* fields
 data StrictnessMark = MarkedStrict | NotMarkedStrict
 
-{-
+{- Note [Bangs on data constructor arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data T = MkT !Int {-# UNPACK #-} !Int Bool
+
+When compiling the module, GHC will decide how to represent
+MkT, depending on the optimisation level, and settings of
+flags like -funbox-small-strict-fields.  
+
+Terminology:
+  * HsSrcBang:  What the user wrote
+                Constructors: HsNoBang, HsUserBang
+
+  * HsImplBang: What GHC decided
+                Constructors: HsNoBang, HsStrict, HsUnpack
+
+* If T was defined in this module, MkT's dcSrcBangs field 
+  records the [HsSrcBang] of what the user wrote; in the example
+    [ HsSrcBang Nothing True
+    , HsSrcBang (Just True) True
+    , HsNoBang]
+
+* However, if T was defined in an imported module, MkT's dcSrcBangs
+  field gives the [HsImplBang] recording the decisions of the 
+  defining module.  The importing module must follow those decisions,
+  regardless of the flag settings in the importing module.
+
+* The dcr_bangs field of the dcRep field records the [HsImplBang]
+  If T was defined in this module, Without -O the dcr_bangs might be
+    [HsStrict, HsStrict, HsNoBang]
+  With -O it might be
+    [HsStrict, HsUnpack, HsNoBang]
+  With -funbox-small-strict-fields it might be
+    [HsUnpack, HsUnpack, HsNoBang]
+
 Note [Data con representation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The dcRepType field contains the type of the representation of a contructor
@@ -479,26 +537,6 @@ but the rep type is
         Trep :: Int# -> a -> T a
 Actually, the unboxed part isn't implemented yet!
 
-Note [Bangs on data constructor arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  data T = MkT !Int {-# UNPACK #-} !Int Bool
-Its dcArgBangs field records the *users* specifications, in this case
-    [ HsUserBang Nothing True
-    , HsUserBang (Just True) True
-    , HsNoBang]
-See the declaration of HsBang in BasicTypes
-
-The dcr_bangs field of the dcRep field records the *actual, decided*
-representation of the data constructor.  Without -O this might be
-    [HsStrict, HsStrict, HsNoBang]
-With -O it might be
-    [HsStrict, HsUnpack, HsNoBang]
-With -funbox-small-strict-fields it might be
-    [HsUnpack, HsUnpack, HsNoBang]
-
-For imported data types, the dcArgBangs field is just the same as the
-dcr_bangs field; we don't know what the user originally said.
 
 
 ************************************************************************
@@ -539,11 +577,11 @@ instance Data.Data DataCon where
     dataTypeOf _ = mkNoRepType "DataCon"
 
 instance Outputable HsBang where
-    ppr HsNoBang               = empty
-    ppr (HsUserBang prag bang) = pp_unpk prag <+> ppWhen bang (char '!')
-    ppr (HsUnpack Nothing)     = ptext (sLit "Unpk")
-    ppr (HsUnpack (Just co))   = ptext (sLit "Unpk") <> parens (ppr co)
-    ppr HsStrict               = ptext (sLit "SrictNotUnpacked")
+    ppr HsNoBang                = empty
+    ppr (HsSrcBang _ prag bang) = pp_unpk prag <+> ppWhen bang (char '!')
+    ppr (HsUnpack Nothing)      = ptext (sLit "Unpk")
+    ppr (HsUnpack (Just co))    = ptext (sLit "Unpk") <> parens (ppr co)
+    ppr HsStrict                = ptext (sLit "SrictNotUnpacked")
 
 pp_unpk :: Maybe Bool -> SDoc
 pp_unpk Nothing      = empty
@@ -558,15 +596,16 @@ instance Outputable StrictnessMark where
 eqHsBang :: HsBang -> HsBang -> Bool
 eqHsBang HsNoBang             HsNoBang             = True
 eqHsBang HsStrict             HsStrict             = True
-eqHsBang (HsUserBang u1 b1)   (HsUserBang u2 b2)   = u1==u2 && b1==b2
+eqHsBang (HsSrcBang _ u1 b1)  (HsSrcBang _ u2 b2)  = u1==u2 && b1==b2
 eqHsBang (HsUnpack Nothing)   (HsUnpack Nothing)   = True
 eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2)
 eqHsBang _ _ = False
 
 isBanged :: HsBang -> Bool
-isBanged HsNoBang                  = False
-isBanged (HsUserBang Nothing bang) = bang
-isBanged _                         = True
+isBanged HsNoBang             = False
+isBanged (HsSrcBang _ _ bang) = bang
+isBanged (HsUnpack {})        = True
+isBanged (HsStrict {})        = True
 
 isMarkedStrict :: StrictnessMark -> Bool
 isMarkedStrict NotMarkedStrict = False
@@ -583,7 +622,8 @@ isMarkedStrict _               = True   -- All others are strict
 -- | Build a new data constructor
 mkDataCon :: Name
           -> Bool               -- ^ Is the constructor declared infix?
-          -> [HsBang]           -- ^ Strictness annotations written in the source file
+          -> [HsBang]           -- ^ Strictness/unpack annotations, from user;
+                                --   or, for imported DataCons, from the interface file 
           -> [FieldLabel]       -- ^ Field labels for the constructor, if it is a record,
                                 --   otherwise empty
           -> [TyVar]            -- ^ Universally quantified type variables
@@ -626,7 +666,7 @@ mkDataCon name declared_infix
                   dcStupidTheta = stupid_theta,
                   dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
                   dcRepTyCon = rep_tycon,
-                  dcArgBangs = arg_stricts,
+                  dcSrcBangs = arg_stricts,
                   dcFields = fields, dcTag = tag, dcRepType = rep_ty,
                   dcWorkId = work_id,
                   dcRep = rep,
@@ -764,10 +804,10 @@ dataConFieldType con label
       Just ty -> ty
       Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label)
 
--- | The strictness markings decided on by the compiler.  Does not include those for
--- existential dictionaries.  The list is in one-to-one correspondence with the arity of the 'DataCon'
-dataConStrictMarks :: DataCon -> [HsBang]
-dataConStrictMarks = dcArgBangs
+-- | The strictness markings written by the porgrammer.
+-- The list is in one-to-one correspondence with the arity of the 'DataCon'
+dataConSrcBangs :: DataCon -> [HsSrcBang]
+dataConSrcBangs = dcSrcBangs
 
 -- | Source-level arity of the data constructor
 dataConSourceArity :: DataCon -> Arity
@@ -800,10 +840,13 @@ dataConRepStrictness dc = case dcRep dc of
                             NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc]
                             DCR { dcr_stricts = strs } -> strs
 
-dataConRepBangs :: DataCon -> [HsBang]
-dataConRepBangs dc = case dcRep dc of
-                       NoDataConRep -> dcArgBangs dc
-                       DCR { dcr_bangs = bangs } -> bangs
+dataConImplBangs :: DataCon -> [HsImplBang]
+-- The implementation decisions about the strictness/unpack of each
+-- source program argument to the data constructor
+dataConImplBangs dc
+  = case dcRep dc of
+      NoDataConRep              -> replicate (dcSourceArity dc) HsNoBang
+      DCR { dcr_bangs = bangs } -> bangs
 
 dataConBoxer :: DataCon -> Maybe DataConBoxer
 dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer

compiler/basicTypes/MkId.hs

@@ -32,6 +32,7 @@ module MkId (
         voidPrimId, voidArgId,
         nullAddrId, seqId, lazyId, lazyIdKey,
         coercionTokenId, magicDictId, coerceId,
+        proxyHashId,
 
         -- Re-export error Ids
         module PrelRules
@@ -519,7 +520,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
     wrap_ty      = dataConUserType data_con
     ev_tys       = eqSpecPreds eq_spec ++ theta
     all_arg_tys  = ev_tys                         ++ orig_arg_tys
-    orig_bangs   = map mk_pred_strict_mark ev_tys ++ dataConStrictMarks data_con
+    orig_bangs   = map mk_pred_strict_mark ev_tys ++ dataConSrcBangs data_con
 
     wrap_arg_tys = theta ++ orig_arg_tys
     wrap_arity   = length wrap_arg_tys
@@ -580,19 +581,26 @@ newLocal ty = do { uniq <- getUniqueM
 dataConArgRep
    :: DynFlags
    -> FamInstEnvs
-   -> Type -> HsBang
-   -> ( HsBang   -- Like input but with HsUnpackFailed if necy
+   -> Type 
+   -> HsSrcBang     -- For DataCons defined in this module, this is the
+                    --    bang/unpack annotation that the programmer wrote
+                    -- For DataCons imported from an interface file, this
+                    --    is the HsImplBang implementation decision taken
+                    --    by the compiler in the defining module; just follow
+                    --    it slavishly, so that we make the same decision as
+                    --    in the defining module
+   -> ( HsImplBang                 -- Implementation decision about unpack strategy
       , [(Type, StrictnessMark)]   -- Rep types
       , (Unboxer, Boxer) )
 
 dataConArgRep _ _ arg_ty HsNoBang
   = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
 
-dataConArgRep _ _ arg_ty (HsUserBang _ False)  -- No '!'
+dataConArgRep _ _ arg_ty (HsSrcBang _ _ False)  -- No '!'
   = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
 
 dataConArgRep dflags fam_envs arg_ty
-    (HsUserBang unpk_prag True)  -- {-# UNPACK #-} !
+    (HsSrcBang _ unpk_prag True)  -- {-# UNPACK #-} !
   | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
           -- Don't unpack if we aren't optimising; rather arbitrarily,
           -- we use -fomit-iface-pragmas as the indication
@@ -625,7 +633,7 @@ dataConArgRep _ _ _ (HsUnpack (Just co))
   , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty
   = (HsUnpack (Just co), rep_tys, wrapCo co co_rep_ty wrappers)
 
-strict_but_not_unpacked :: Type -> (HsBang, [(Type,StrictnessMark)], (Unboxer, Boxer))
+strict_but_not_unpacked :: Type -> (HsImplBang, [(Type,StrictnessMark)], (Unboxer, Boxer))
 strict_but_not_unpacked arg_ty
   = (HsStrict, [(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))
 
@@ -716,15 +724,15 @@ isUnpackableType fam_envs ty
       = True
 
     ok_con_args tcs con
-       = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConStrictMarks con)
-         -- NB: dataConStrictMarks gives the *user* request;
-         -- We'd get a black hole if we used dataConRepBangs
+       = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConSrcBangs con)
+         -- NB: dataConSrcBangs gives the *user* request;
+         -- We'd get a black hole if we used dataConImplBangs
 
-    attempt_unpack (HsUnpack {})                 = True
-    attempt_unpack (HsUserBang (Just unpk) bang) = bang && unpk
-    attempt_unpack (HsUserBang Nothing bang)     = bang  -- Be conservative
-    attempt_unpack HsStrict                      = False
-    attempt_unpack HsNoBang                      = False
+    attempt_unpack (HsUnpack {})                  = True
+    attempt_unpack (HsSrcBang _ (Just unpk) bang) = bang && unpk
+    attempt_unpack (HsSrcBang _  Nothing bang)     = bang  -- Be conservative
+    attempt_unpack HsStrict                       = False
+    attempt_unpack HsNoBang                       = False
 
 {-
 Note [Unpack one-wide fields]
@@ -789,7 +797,7 @@ heavy lifting.  This one line makes every GADT take a word less
 space for each equality predicate, so it's pretty important!
 -}
 
-mk_pred_strict_mark :: PredType -> HsBang
+mk_pred_strict_mark :: PredType -> HsSrcBang
 mk_pred_strict_mark pred
   | isEqPred pred = HsUnpack Nothing    -- Note [Unpack equality predicates]
   | otherwise     = HsNoBang

compiler/basicTypes/Name.hs

@@ -189,7 +189,6 @@ nameSrcSpan name = n_loc  name
 ************************************************************************
 -}
 
-nameIsLocalOrFrom :: Module -> Name -> Bool
 isInternalName    :: Name -> Bool
 isExternalName    :: Name -> Bool
 isSystemName      :: Name -> Bool
@@ -218,9 +217,32 @@ nameModule_maybe (Name { n_sort = External mod})    = Just mod
 nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod
 nameModule_maybe _                                  = Nothing
 
+nameIsLocalOrFrom :: Module -> Name -> Bool
+-- ^ Returns True if the name is
+--   (a) Internal
+--   (b) External but from the specified module
+--   (c) External but from the 'interactive' package
+--
+-- The key idea is that
+--    False means: the entity is defined in some other module
+--                 you can find the details (type, fixity, instances)
+--                     in some interface file
+--                 those details will be stored in the EPT or HPT
+--
+--    True means:  the entity is defined in this module or earlier in
+--                     the GHCi session
+--                 you can find details (type, fixity, instances) in the
+--                     TcGblEnv or TcLclEnv
+--
+-- The isInteractiveModule part is because successive interactions of a GCHi session
+-- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come
+-- from the magic 'interactive' package; and all the details are kept in the
+-- TcLclEnv, TcGblEnv, NOT in the HPT or EPT.
+-- See Note [The interactive package] in HscTypes
+
 nameIsLocalOrFrom from name
-  | isExternalName name = from == nameModule name
-  | otherwise           = True
+  | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod
+  | otherwise                         = True
 
 isTyVarName :: Name -> Bool
 isTyVarName name = isTvOcc (nameOccName name)
@@ -334,7 +356,8 @@ localiseName n = n { n_sort = Internal }
 -- |Create a localised variant of a name.
 --
 -- If the name is external, encode the original's module name to disambiguate.
---
+-- SPJ says: this looks like a rather odd-looking function; but it seems to
+--           be used only during vectorisation, so I'm not going to worry
 mkLocalisedOccName :: Module -> (Maybe String -> OccName -> OccName) -> Name -> OccName
 mkLocalisedOccName this_mod mk_occ name = mk_occ origin (nameOccName name)
   where

compiler/basicTypes/RdrName.hs

@@ -86,6 +86,22 @@ import Data.Data
 
 -- | Do not use the data constructors of RdrName directly: prefer the family
 -- of functions that creates them, such as 'mkRdrUnqual'
+--
+-- - Note: A Located RdrName will only have API Annotations if it is a
+--         compound one,
+--   e.g.
+--
+-- > `bar`
+-- > ( ~ )
+--
+-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
+--           'ApiAnnotation.AnnOpen'  @'('@ or @'['@ or @'[:'@,
+--           'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,,
+--           'ApiAnnotation.AnnBackquote' @'`'@,
+--           'ApiAnnotation.AnnVal','ApiAnnotation.AnnTildehsh',
+--           'ApiAnnotation.AnnTilde',
+
+-- For details on above see note [Api annotations] in ApiAnnotation
 data RdrName
   = Unqual OccName
         -- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.

compiler/basicTypes/SrcLoc.hs

 -- (c) The University of Glasgow, 1992-2006
 
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveFoldable     #-}
+{-# LANGUAGE DeriveTraversable  #-}
+{-# LANGUAGE FlexibleInstances  #-}
 {-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
    -- Workaround for Trac #5252 crashes the bootstrap compiler without -O
    -- When the earliest compiler we want to boostrap with is
@@ -43,7 +48,7 @@ module SrcLoc (
         srcSpanStart, srcSpanEnd,
         realSrcSpanStart, realSrcSpanEnd,
         srcSpanFileName_maybe,
-        showUserSpan, pprUserRealSpan,
+        pprUserRealSpan,
 
         -- ** Unsafely deconstructing SrcSpan
         -- These are dubious exports, because they crash on some inputs
@@ -77,6 +82,10 @@ import Util
 import Outputable
 import FastString
 
+#if __GLASGOW_HASKELL__ < 709
+import Data.Foldable ( Foldable )
+import Data.Traversable ( Traversable )
+#endif
 import Data.Bits
 import Data.Data
 import Data.List
@@ -475,9 +484,6 @@ instance Outputable SrcSpan where
 --           UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"
 --           RealSrcSpan s -> ppr s
 
-showUserSpan :: Bool -> SrcSpan -> String
-showUserSpan show_path span = showSDocSimple (pprUserSpan show_path span)
-
 pprUserSpan :: Bool -> SrcSpan -> SDoc
 pprUserSpan _         (UnhelpfulSpan s) = ftext s
 pprUserSpan show_path (RealSrcSpan s)   = pprUserRealSpan show_path s
@@ -515,6 +521,8 @@ pprUserRealSpan show_path (SrcSpanPoint src_path line col)
 -- | We attach SrcSpans to lots of things, so let's have a datatype for it.
 data GenLocated l e = L l e
   deriving (Eq, Ord, Typeable, Data)
+deriving instance Foldable    (GenLocated l)
+deriving instance Traversable (GenLocated l)
 
 type Located e = GenLocated SrcSpan e
 type RealLocated e = GenLocated RealSrcSpan e

compiler/cmm/CLabel.hs

@@ -897,7 +897,7 @@ labelDynamic dflags this_pkg this_mod lbl =
 
    PlainModuleInitLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageKey m)
 
-   HpcTicksLabel m        -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageKey m)
+   HpcTicksLabel m        -> not (gopt Opt_Static dflags) && this_mod /= m
 
    -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
    _                 -> False

compiler/cmm/CmmParse.y

@@ -575,6 +575,10 @@ importName
         : NAME  
         { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
 
+        -- as previous 'NAME', but 'IsData'
+        | 'CLOSURE' NAME
+        { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }
+
         -- A label imported with an explicit packageId.
         | STRING NAME
         { ($2, mkCmmCodeLabel (fsToPackageKey (mkFastString $1)) $2) }

compiler/coreSyn/CoreLint.hs

@@ -1759,7 +1759,7 @@ withoutAnnots pass guts = do
   -- Nuke existing ticks in module.
   -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
   -- them in absence of @Opt_Debug@?
-  let nukeTicks = snd . stripTicks (not . tickishIsCode)
+  let nukeTicks = stripTicksE (not . tickishIsCode)
       nukeAnnotsBind :: CoreBind -> CoreBind
       nukeAnnotsBind bind = case bind of
         Rec bs     -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs

compiler/coreSyn/CoreUtils.hs

@@ -44,7 +44,8 @@ module CoreUtils (
         dataConRepInstPat, dataConRepFSInstPat,
 
         -- * Working with ticks
-        stripTicksTop, stripTicksTopE, stripTicksTopT, stripTicks,
+        stripTicksTop, stripTicksTopE, stripTicksTopT,
+        stripTicksE, stripTicksT
     ) where
 
 #include "HsVersions.h"
@@ -77,10 +78,6 @@ import Pair
 import Data.Function       ( on )
 import Data.List
 import Data.Ord            ( comparing )
-import Control.Applicative
-#if __GLASGOW_HASKELL__ < 709
-import Data.Traversable    ( traverse )
-#endif
 import OrdList
 
 {-
@@ -300,10 +297,18 @@ mkTick t orig_expr = mkTick' id id orig_expr
          else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr
 
     Var x
-      | not (isFunTy (idType x)) && tickishPlace t == PlaceCostCentre
+      | notFunction && tickishPlace t == PlaceCostCentre
       -> orig_expr
-      | canSplit
+      | notFunction && canSplit
       -> top $ Tick (mkNoScope t) $ rest expr
+      where
+        -- SCCs can be eliminated on variables provided the variable
+        -- is not a function.  In these cases the SCC makes no difference:
+        -- the cost of evaluating the variable will be attributed to its
+        -- definition site.  When the variable refers to a function, however,
+        -- an SCC annotation on the variable affects the cost-centre stack
+        -- when the function is called, so we must retain those.
+        notFunction = not (isFunTy (idType x))
 
     Lit{}
       | tickishPlace t == PlaceCostCentre
@@ -358,25 +363,37 @@ stripTicksTopT p = go []
 
 -- | Completely strip ticks satisfying a predicate from an
 -- expression. Note this is O(n) in the size of the expression!
-stripTicks :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
-stripTicks p expr = (fromOL ticks, expr')
-  where (ticks, expr') = go expr
-        -- Note that  OrdList (Tickish Id) is a Monoid, which makes
-        -- ((,) (OrdList (Tickish Id))) an Applicative.
-        go (App e a)        = App <$> go e <*> go a
-        go (Lam b e)        = Lam b <$> go e
-        go (Let b e)        = Let <$> go_bs b <*> go e
-        go (Case e b t as)  = Case <$> go e <*> pure b <*> pure t
-                                   <*> traverse go_a as
-        go (Cast e c)       = Cast <$> go e <*> pure c
+stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b
+stripTicksE p expr = go expr
+  where go (App e a)        = App (go e) (go a)
+        go (Lam b e)        = Lam b (go e)
+        go (Let b e)        = Let (go_bs b) (go e)
+        go (Case e b t as)  = Case (go e) b t (map go_a as)
+        go (Cast e c)       = Cast (go e) c
+        go (Tick t e)
+          | p t             = go e
+          | otherwise       = Tick t (go e)
+        go other            = other
+        go_bs (NonRec b e)  = NonRec b (go e)
+        go_bs (Rec bs)      = Rec (map go_b bs)
+        go_b (b, e)         = (b, go e)
+        go_a (c,bs,e)       = (c,bs, go e)
+
+stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
+stripTicksT p expr = fromOL $ go expr
+  where go (App e a)        = go e `appOL` go a
+        go (Lam _ e)        = go e
+        go (Let b e)        = go_bs b `appOL` go e
+        go (Case e _ _ as)  = go e `appOL` concatOL (map go_a as)
+        go (Cast e _)       = go e
         go (Tick t e)
-          | p t             = let (ts, e') = go e in (t `consOL` ts, e')
-          | otherwise       = Tick t <$> go e
-        go other            = pure other
-        go_bs (NonRec b e)  = NonRec b <$> go e
-        go_bs (Rec bs)      = Rec <$> traverse go_b bs
-        go_b (b, e)         = (,) <$> pure b <*> go e
-        go_a (c,bs,e)       = (,,) <$> pure c <*> pure bs <*> go e
+          | p t             = t `consOL` go e
+          | otherwise       = go e
+        go _                = nilOL
+        go_bs (NonRec _ e)  = go e
+        go_bs (Rec bs)      = concatOL (map go_b bs)
+        go_b (_, e)         = go e
+        go_a (_, _, e)      = go e
 
 {-
 ************************************************************************
@@ -663,6 +680,7 @@ getIdFromTrivialExpr :: CoreExpr -> Id
 getIdFromTrivialExpr e = go e
   where go (Var v) = v
         go (App f t) | not (isRuntimeArg t) = go f
+        go (Tick t e) | not (tickishIsCode t) = go e
         go (Cast e _) = go e
         go (Lam b e) | not (isRuntimeVar b) = go e
         go e = pprPanic "getIdFromTrivialExpr" (ppr e)

compiler/deSugar/Check.hs

@@ -452,11 +452,11 @@ get_lit :: Pat id -> Maybe HsLit
 -- It doesn't matter which one, because they will only be compared
 -- with other HsLits gotten in the same way
 get_lit (LitPat lit)                                      = Just lit
-get_lit (NPat (OverLit { ol_val = HsIntegral src i})    mb _)
+get_lit (NPat (L _ (OverLit { ol_val = HsIntegral src i}))    mb _)
                         = Just (HsIntPrim src (mb_neg negate              mb i))
-get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _)
+get_lit (NPat (L _ (OverLit { ol_val = HsFractional f })) mb _)
                         = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))
-get_lit (NPat (OverLit { ol_val = HsIsString src s })   _  _)
+get_lit (NPat (L _ (OverLit { ol_val = HsIsString src s }))   _  _)
                         = Just (HsStringPrim src (fastStringToByteString s))
 get_lit _                                                 = Nothing
 
@@ -727,7 +727,7 @@ tidy_pat (TuplePat ps boxity tys)
   where
     arity = length ps
 
-tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq
+tidy_pat (NPat (L _ lit) mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq
 tidy_pat (LitPat lit)         = tidy_lit_pat lit
 
 tidy_pat (ConPatIn {})        = panic "Check.tidy_pat: ConPatIn"

compiler/deSugar/Coverage.hs

@@ -567,7 +567,7 @@ addTickHsExpr (HsTick t e) =
 addTickHsExpr (HsBinTick t0 t1 e) =
         liftM (HsBinTick t0 t1) (addTickLHsExprNever e)
 
-addTickHsExpr (HsTickPragma _ (L pos e0)) = do
+addTickHsExpr (HsTickPragma _ _ (L pos e0)) = do
     e2 <- allocTickBox (ExpBox False) False False pos $
                 addTickHsExpr e0
     return $ unLoc e2
@@ -575,12 +575,14 @@ addTickHsExpr (PArrSeq   ty arith_seq) =
         liftM2 PArrSeq
                 (return ty)
                 (addTickArithSeqInfo arith_seq)
-addTickHsExpr (HsSCC nm e) =
-        liftM2 HsSCC
+addTickHsExpr (HsSCC src nm e) =
+        liftM3 HsSCC
+                (return src)
                 (return nm)
                 (addTickLHsExpr e)
-addTickHsExpr (HsCoreAnn nm e) =
-        liftM2 HsCoreAnn
+addTickHsExpr (HsCoreAnn src nm e) =
+        liftM3 HsCoreAnn
+                (return src)
                 (return nm)
                 (addTickLHsExpr e)
 addTickHsExpr e@(HsBracket     {})   = return e
@@ -614,10 +616,10 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do
   return $ mg { mg_alts = matches' }
 
 addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
-addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) =
+addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =
   bindLocals (collectPatsBinders pats) $ do
     gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
-    return $ Match pats opSig gRHSs'
+    return $ Match mf pats opSig gRHSs'
 
 addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))
 addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
@@ -829,10 +831,10 @@ addTickCmdMatchGroup mg@(MG { mg_alts = matches }) = do
   return $ mg { mg_alts = matches' }
 
 addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
-addTickCmdMatch (Match pats opSig gRHSs) =
+addTickCmdMatch (Match mf pats opSig gRHSs) =
   bindLocals (collectPatsBinders pats) $ do
     gRHSs' <- addTickCmdGRHSs gRHSs
-    return $ Match pats opSig gRHSs'
+    return $ Match mf pats opSig gRHSs'
 
 addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))
 addTickCmdGRHSs (GRHSs guarded local_binds) = do
@@ -1204,7 +1206,7 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
 matchesOneOfMany :: [LMatch Id body] -> Bool
 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
   where
-        matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
+        matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss
 
 type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
 

compiler/deSugar/Desugar.hs

@@ -24,7 +24,6 @@ import Coercion
 import InstEnv
 import Class
 import Avail
-import PatSyn
 import CoreSyn
 import CoreSubst
 import PprCore
@@ -184,7 +183,7 @@ deSugar hsc_env
                 mg_fam_insts    = fam_insts,
                 mg_inst_env     = inst_env,
                 mg_fam_inst_env = fam_inst_env,
-                mg_patsyns      = filter ((`elemNameSet` export_set) . patSynName) patsyns,
+                mg_patsyns      = patsyns,
                 mg_rules        = ds_rules_for_imps,
                 mg_binds        = ds_binds,
                 mg_foreign      = ds_fords,
@@ -462,12 +461,12 @@ by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
 -}
 
 dsVect :: LVectDecl Id -> DsM CoreVect
-dsVect (L loc (HsVect (L _ v) rhs))
+dsVect (L loc (HsVect _ (L _ v) rhs))
   = putSrcSpanDs loc $
     do { rhs' <- dsLExpr rhs
        ; return $ Vect v rhs'
        }
-dsVect (L _loc (HsNoVect (L _ v)))
+dsVect (L _loc (HsNoVect _ (L _ v)))
   = return $ NoVect v
 dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
   = return $ VectType isScalar tycon' rhs_tycon
@@ -475,11 +474,11 @@ dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
     tycon' | Just ty <- coreView $ mkTyConTy tycon
            , (tycon', []) <- splitTyConApp ty      = tycon'
            | otherwise                             = tycon
-dsVect vd@(L _ (HsVectTypeIn _ _ _))
+dsVect vd@(L _ (HsVectTypeIn _ _ _ _))
   = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
 dsVect (L _loc (HsVectClassOut cls))
   = return $ VectClass (classTyCon cls)
-dsVect vc@(L _ (HsVectClassIn _))
+dsVect vc@(L _ (HsVectClassIn _ _))
   = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
 dsVect (L _loc (HsVectInstOut inst))
   = return $ VectInst (instanceDFunId inst)