.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,14 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS],
         $3="$$3 -D_HPUX_SOURCE"
         $5="$$5 -D_HPUX_SOURCE"
         ;;
+    arm*linux*       | \
+    aarch64*linux*   )
+        # On arm/linux, aarch64/linux, arm/android and aarch64/android, tell
+        # gcc to link using the gold linker.
+        # Forcing LD to be ld.gold is done in FIND_LD m4 macro.
+        $3="$$3 -fuse-ld=gold -Wl,-z,noexecstack"
+        $4="$$4 -z noexecstack"
+        ;;
     esac
 
     # If gcc knows about the stack protector, turn it off.
@@ -1581,6 +1589,7 @@ if test "$RELEASE" = "NO"; then
         dnl less likely to go wrong.
         PACKAGE_VERSION=${PACKAGE_VERSION}.`date +%Y%m%d`
     fi
+fi
 
     AC_MSG_CHECKING([for GHC Git commit id])
     if test -d .git; then
@@ -1598,7 +1607,6 @@ if test "$RELEASE" = "NO"; then
         PACKAGE_GIT_COMMIT_ID="0000000000000000000000000000000000000000"
     fi
 
-fi
 
 # Some renamings
 AC_SUBST([ProjectName], [$PACKAGE_NAME])
@@ -1826,6 +1834,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
 # --------------------------------------------------------------
@@ -2069,28 +2099,67 @@ AC_DEFUN([XCODE_VERSION],[
 # $1 = the variable to set
 # $2 = the with option name
 # $3 = the command to look for
+# $4 = the version of the command to look for
 #
 AC_DEFUN([FIND_LLVM_PROG],[
-    FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL_NOTARGET([$1], [$2], [$3])
-    if test "$$1" == ""; then
-        save_IFS=$IFS
-        IFS=":;"
-        for p in ${PATH}; do
-            if test -d "${p}"; then
-                if test "$windows" = YES; then
-                    $1=`${FindCmd} "${p}" -type f -maxdepth 1 -regex '.*/$3-[[0-9]]\.[[0-9]]' -or -type l -maxdepth 1 -regex '.*/$3-[[0-9]]\.[[0-9]]' | ${SortCmd} -n | tail -1`
-                else
-                    $1=`${FindCmd} "${p}" -type f -perm \111 -maxdepth 1 -regex '.*/$3-[[0-9]]\.[[0-9]]' -or -type l -perm \111 -maxdepth 1 -regex '.*/$3-[[0-9]]\.[[0-9]]' | ${SortCmd} -n | tail -1`
-                fi
-                if test -n "$$1"; then
-                    break
-                fi
-            fi
-        done
-        IFS=$save_IFS
+    # Test for program with version name.
+    FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL_NOTARGET([$1], [$2], [$3-$4])
+    if test "$$1" = ""; then
+        # Test for program without version name.
+        FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL_NOTARGET([$1], [$2], [$3])
+        AC_MSG_CHECKING([$$1 is version $4])
+        if test `$$1 --version | grep -c "version $4"` -gt 0 ; then
+            AC_MSG_RESULT(yes)
+        else
+            AC_MSG_RESULT(no)
+            $1=""
+        fi
+    fi
+])
+
+# FIND_LD
+# Find the version of `ld` to use. This is used in both in the top level
+# configure.ac and in distrib/configure.ac.in.
+#
+# $1 = the variable to set
+#
+AC_DEFUN([FIND_LD],[
+    FP_ARG_WITH_PATH_GNU_PROG([LD], [ld], [ld])
+    case $target in
+        arm*linux*       | \
+        aarch64*linux*   )
+            # Arm and Aarch64 requires use of the binutils ld.gold linker.
+            # This case should catch at least arm-unknown-linux-gnueabihf,
+            # arm-linux-androideabi, arm64-unknown-linux and
+            # aarch64-linux-android
+            FP_ARG_WITH_PATH_GNU_PROG([LD_GOLD], [ld.gold], [ld.gold])
+            $1="$LD_GOLD"
+            ;;
+        *)
+            $1="$LD"
+            ;;
+    esac
+])
+
+# FIND_GHC_BOOTSTRAP_PROG()
+# --------------------------------
+# Parse the bootstrap GHC's compier settings file for the location of things
+# like the `llc` and `opt` commands.
+#
+# $1 = the variable to set
+# $2 = The bootstrap compiler.
+# $3 = The string to grep for to find the correct line.
+#
+AC_DEFUN([FIND_GHC_BOOTSTRAP_PROG],[
+    BootstrapTmpCmd=`grep $3 $($2 --print-libdir)/settings 2>/dev/null | sed 's/.*", "//;s/".*//'`
+    if test -n "$BootstrapTmpCmd" && test `basename $BootstrapTmpCmd` = $BootstrapTmpCmd ; then
+        AC_PATH_PROG([$1], [$BootstrapTmpCmd], "")
+    else
+        $1=$BootstrapTmpCmd
     fi
 ])
 
+
 # FIND_GCC()
 # --------------------------------
 # Finds where gcc is

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

@@ -18,6 +18,7 @@ module Demand (
         lubDmd, bothDmd, apply1Dmd, apply2Dmd,
         isTopDmd, isBotDmd, isAbsDmd, isSeqDmd,
         peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd,
+        addCaseBndrDmd,
 
         DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,
         nopDmdType, botDmdType, mkDmdType,
@@ -25,7 +26,7 @@ module Demand (
         BothDmdArg, mkBothDmdArg, toBothDmdArg,
 
         DmdEnv, emptyDmdEnv,
-        peelFV,
+        peelFV, findIdDemand,
 
         DmdResult, CPRResult,
         isBotRes, isTopRes,
@@ -47,8 +48,8 @@ module Demand (
         argOneShots, argsOneShots,
         trimToType, TypeShape(..),
 
-        isSingleUsed, reuseEnv, zapDemand, zapStrictSig,
-
+        isSingleUsed, reuseEnv,
+        killUsageDemand, killUsageSig, zapUsageDemand,
         strictifyDictDmd
 
      ) where
@@ -200,6 +201,10 @@ seqMaybeStr Lazy    = ()
 seqMaybeStr (Str s) = seqStrDmd s
 
 -- Splitting polymorphic demands
+splitMaybeStrProdDmd :: Int -> MaybeStr -> Maybe [MaybeStr]
+splitMaybeStrProdDmd n Lazy    = Just (replicate n Lazy)
+splitMaybeStrProdDmd n (Str s) = splitStrProdDmd n s
+
 splitStrProdDmd :: Int -> StrDmd -> Maybe [MaybeStr]
 splitStrProdDmd n HyperStr   = Just (replicate n strBot)
 splitStrProdDmd n HeadStr    = Just (replicate n strTop)
@@ -352,7 +357,49 @@ peelUseCall :: UseDmd -> Maybe (Count, UseDmd)
 peelUseCall (UCall c u)   = Just (c,u)
 peelUseCall _             = Nothing
 
-{-
+addCaseBndrDmd :: Demand    -- On the case binder
+               -> [Demand]  -- On the components of the constructor
+               -> [Demand]  -- Final demands for the components of the constructor
+-- See Note [Demand on case-alternative binders]
+addCaseBndrDmd (JD { strd = ms, absd = mu }) alt_dmds
+  = case mu of
+     Abs     -> alt_dmds
+     Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us)
+             where
+                Just ss = splitMaybeStrProdDmd arity ms  -- Guaranteed not to be a call
+                Just us = splitUseProdDmd      arity u   -- Ditto
+  where
+    arity = length alt_dmds
+
+{- Note [Demand on case-alternative binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The demand on a binder in a case alternative comes
+  (a) From the demand on the binder itself
+  (b) From the demand on the case binder
+Forgetting (b) led directly to Trac #10148.
+
+Example. Source code:
+  f x@(p,_) = if p then foo x else True
+
+  foo (p,True) = True
+  foo (p,q)    = foo (q,p)
+
+After strictness analysis:
+  f = \ (x_an1 [Dmd=<S(SL),1*U(U,1*U)>] :: (Bool, Bool)) ->
+      case x_an1
+      of wild_X7 [Dmd=<L,1*U(1*U,1*U)>]
+      { (p_an2 [Dmd=<S,1*U>], ds_dnz [Dmd=<L,A>]) ->
+      case p_an2 of _ {
+        False -> GHC.Types.True;
+        True -> foo wild_X7 }
+
+It's true that ds_dnz is *itself* absent, b ut the use of wild_X7 means
+that it is very much alive and demanded.  See Trac #10148 for how the
+consequences play out.
+
+This is needed even for non-product types, in case the case-binder
+is used but the components of the case alternative are not.
+
 Note [Don't optimise UProd(Used) to Used]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 These two UseDmds:
@@ -586,7 +633,8 @@ f g = (snd (g 3), True)
 should be: <L,C(U(AU))>m
 -}
 
-data CleanDemand = CD { sd :: StrDmd, ud :: UseDmd }
+data CleanDemand   -- A demand that is at least head-strict
+  = CD { sd :: StrDmd, ud :: UseDmd }
   deriving ( Eq, Show )
 
 instance Outputable CleanDemand where
@@ -1339,6 +1387,10 @@ peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)
 addDemand :: Demand -> DmdType -> DmdType
 addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res
 
+findIdDemand :: DmdType -> Var -> Demand
+findIdDemand (DmdType fv _ res) id
+  = lookupVarEnv fv id `orElse` defaultDmd res
+
 {-
 Note [Default demand on free variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1663,21 +1715,34 @@ of arguments, says conservatively if the function is going to diverge
 or not.
 
 Zap absence or one-shot information, under control of flags
+
+Note [Killing usage information]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The flags -fkill-one-shot and -fkill-absence let you switch off the generation
+of absence or one-shot information altogether.  This is only used for performance
+tests, to see how important they are.
 -}
 
-zapDemand :: DynFlags -> Demand -> Demand
-zapDemand dflags dmd
-  | Just kfs <- killFlags dflags = zap_dmd kfs dmd
+zapUsageDemand :: Demand -> Demand
+-- Remove the usage info, but not the strictness info, from the demand
+zapUsageDemand = kill_usage (True, True)
+
+killUsageDemand :: DynFlags -> Demand -> Demand
+-- See Note [Killing usage information]
+killUsageDemand dflags dmd
+  | Just kfs <- killFlags dflags = kill_usage kfs dmd
   | otherwise                    = dmd
 
-zapStrictSig :: DynFlags -> StrictSig -> StrictSig
-zapStrictSig dflags sig@(StrictSig (DmdType env ds r))
-  | Just kfs <- killFlags dflags = StrictSig (DmdType env (map (zap_dmd kfs) ds) r)
+killUsageSig :: DynFlags -> StrictSig -> StrictSig
+-- See Note [Killing usage information]
+killUsageSig dflags sig@(StrictSig (DmdType env ds r))
+  | Just kfs <- killFlags dflags = StrictSig (DmdType env (map (kill_usage kfs) ds) r)
   | otherwise                    = sig
 
 type KillFlags = (Bool, Bool)
 
 killFlags :: DynFlags -> Maybe KillFlags
+-- See Note [Killing usage information]
 killFlags dflags
   | not kill_abs && not kill_one_shot = Nothing
   | otherwise                         = Just (kill_abs, kill_one_shot)
@@ -1685,8 +1750,8 @@ killFlags dflags
     kill_abs      = gopt Opt_KillAbsence dflags
     kill_one_shot = gopt Opt_KillOneShot dflags
 
-zap_dmd :: KillFlags -> Demand -> Demand
-zap_dmd kfs (JD {strd = s, absd = u}) = JD {strd = s, absd = zap_musg kfs u}
+kill_usage :: KillFlags -> Demand -> Demand
+kill_usage kfs (JD {strd = s, absd = u}) = JD {strd = s, absd = zap_musg kfs u}
 
 zap_musg :: KillFlags -> MaybeUsed -> MaybeUsed
 zap_musg (kill_abs, _) Abs

compiler/basicTypes/Id.hs

@@ -45,8 +45,9 @@ module Id (
         setIdExported, setIdNotExported,
         globaliseId, localiseId,
         setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
-        zapLamIdInfo, zapDemandIdInfo, zapFragileIdInfo, transferPolyIdInfo,
+        zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapFragileIdInfo,
         zapIdStrictness,
+        transferPolyIdInfo,
 
         -- ** Predicates on Ids
         isImplicitId, isDeadBinder,
@@ -738,8 +739,11 @@ zapLamIdInfo = zapInfo zapLamInfo
 zapFragileIdInfo :: Id -> Id
 zapFragileIdInfo = zapInfo zapFragileInfo
 
-zapDemandIdInfo :: Id -> Id
-zapDemandIdInfo = zapInfo zapDemandInfo
+zapIdDemandInfo :: Id -> Id
+zapIdDemandInfo = zapInfo zapDemandInfo
+
+zapIdUsageInfo :: Id -> Id
+zapIdUsageInfo = zapInfo zapUsageInfo
 
 {-
 Note [transferPolyIdInfo]

compiler/basicTypes/IdInfo.hs

@@ -24,7 +24,7 @@ module IdInfo (
 
         -- ** Zapping various forms of Info
         zapLamInfo, zapFragileInfo,
-        zapDemandInfo,
+        zapDemandInfo, zapUsageInfo,
 
         -- ** The ArityInfo type
         ArityInfo,
@@ -484,10 +484,14 @@ zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})
 
     is_safe_dmd dmd = not (isStrictDmd dmd)
 
--- | Remove demand info on the 'IdInfo' if it is present, otherwise return @Nothing@
+-- | Remove all demand info on the 'IdInfo'
 zapDemandInfo :: IdInfo -> Maybe IdInfo
 zapDemandInfo info = Just (info {demandInfo = topDmd})
 
+-- | Remove usage (but not strictness) info on the 'IdInfo'
+zapUsageInfo :: IdInfo -> Maybe IdInfo
+zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)})
+
 zapFragileInfo :: IdInfo -> Maybe IdInfo
 -- ^ Zap info that depends on free variables
 zapFragileInfo info

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
@@ -1078,10 +1086,15 @@ nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
 seqId :: Id     -- See Note [seqId magic]
 seqId = pcMiscPrelId seqName ty info
   where
-    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
+    info = noCafIdInfo `setInlinePragInfo` inline_prag
                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs
                        `setSpecInfo`       mkSpecInfo [seq_cast_rule]
 
+    inline_prag = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter 0
+                  -- Make 'seq' not inline-always, so that simpleOptExpr
+                  -- (see CoreSubst.simple_app) won't inline 'seq' on the
+                  -- LHS of rules.  That way we can have rules for 'seq';
+                  -- see Note [seqId magic]
 
     ty  = mkForAllTys [alphaTyVar,betaTyVar]
                       (mkFunTy alphaTy (mkFunTy betaTy betaTy))
@@ -1091,17 +1104,18 @@ seqId = pcMiscPrelId seqName ty info
     rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)])
 
     -- See Note [Built-in RULES for seq]
+    -- NB: ru_nargs = 3, not 4, to match the code in
+    --     Simplify.rebuildCase which tries to apply this rule
     seq_cast_rule = BuiltinRule { ru_name  = fsLit "seq of cast"
                                 , ru_fn    = seqName
-                                , ru_nargs = 4
-                                , ru_try   = match_seq_of_cast
-                                }
+                                , ru_nargs = 3
+                                , ru_try   = match_seq_of_cast }
 
 match_seq_of_cast :: RuleFun
     -- See Note [Built-in RULES for seq]
-match_seq_of_cast _ _ _ [Type _, Type res_ty, Cast scrut co, expr]
+match_seq_of_cast _ _ _ [Type _, Type res_ty, Cast scrut co]
   = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
-                              scrut, expr])
+                              scrut])
 match_seq_of_cast _ _ _ _ = Nothing
 
 ------------------------------------------------
@@ -1207,16 +1221,24 @@ transform to
 Rather than attempt some general analysis to support this, I've added
 enough support that you can do this using a rewrite rule:
 
-  RULE "f/seq" forall n.  seq (f n) e = seq n e
+  RULE "f/seq" forall n.  seq (f n) = seq n
 
 You write that rule.  When GHC sees a case expression that discards
 its result, it mentally transforms it to a call to 'seq' and looks for
 a RULE.  (This is done in Simplify.rebuildCase.)  As usual, the
 correctness of the rule is up to you.
 
-To make this work, we need to be careful that the magical desugaring
-done in Note [seqId magic] item (c) is *not* done on the LHS of a rule.
-Or rather, we arrange to un-do it, in DsBinds.decomposeRuleLhs.
+VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2.
+If we wrote
+  RULE "f/seq" forall n e.  seq (f n) e = seq n e
+with rule arity 2, then two bad things would happen:
+
+  - The magical desugaring done in Note [seqId magic] item (c)
+    for saturated application of 'seq' would turn the LHS into
+    a case expression!
+
+  - The code in Simplify.rebuildCase would need to actually supply
+    the value argument, which turns out to be awkward.
 
 Note [Built-in RULES for seq]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~

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

@@ -3,7 +3,7 @@
 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 -}
 
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}
 
 -- |
 -- #name_types#
@@ -793,6 +793,29 @@ type TidyOccEnv = UniqFM Int
 
 * When looking for a renaming for "foo2" we strip off the "2" and start
   with "foo".  Otherwise if we tidy twice we get silly names like foo23.
+
+  However, if it started with digits at the end, we always make a name
+  with digits at the end, rather than shortening "foo2" to just "foo",
+  even if "foo" is unused.  Reasons:
+     - Plain "foo" might be used later
+     - We use trailing digits to subtly indicate a unification variable
+       in typechecker error message; see TypeRep.tidyTyVarBndr
+
+We have to take care though! Consider a machine-generated module (Trac #10370)
+  module Foo where
+     a1 = e1
+     a2 = e2
+     ...
+     a2000 = e2000
+Then "a1", "a2" etc are all marked taken.  But now if we come across "a7" again,
+we have to do a linear search to find a free one, "a20001".  That might just be
+acceptable once.  But if we now come across "a8" again, we don't want to repeat
+that search.
+
+So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for
+starting the search; and we make sure to update the starting point for "a"
+after we allocate a new one.
+
 -}
 
 type TidyOccEnv = UniqFM Int    -- The in-scope OccNames
@@ -809,24 +832,30 @@ initTidyOccEnv = foldl add emptyUFM
 tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
 tidyOccName env occ@(OccName occ_sp fs)
   = case lookupUFM env fs of
-        Just n  -> find n
-        Nothing -> (addToUFM env fs 1, occ)
+      Nothing -> (addToUFM env fs 1, occ)   -- Desired OccName is free
+      Just {} -> case lookupUFM env base1 of
+                   Nothing -> (addToUFM env base1 2, OccName occ_sp base1)
+                   Just n  -> find 1 n
   where
     base :: String  -- Drop trailing digits (see Note [TidyOccEnv])
-    base = dropWhileEndLE isDigit (unpackFS fs)
+    base  = dropWhileEndLE isDigit (unpackFS fs)
+    base1 = mkFastString (base ++ "1")
 
-    find n
+    find !k !n
       = case lookupUFM env new_fs of
-          Just n' -> find (n1 `max` n')
-                     -- The max ensures that n increases, avoiding loops
-          Nothing -> (addToUFM (addToUFM env fs n1) new_fs n1,
-                      OccName occ_sp new_fs)
-                     -- We update only the beginning and end of the
-                     -- chain that find explores; it's a little harder to
-                     -- update the middle and there's no real need.
+          Just {} -> find (k+1 :: Int) (n+k)
+                       -- By using n+k, the n arguemt to find goes
+                       --    1, add 1, add 2, add 3, etc which
+                       -- moves at quadratic speed through a dense patch
+
+          Nothing -> (new_env, OccName occ_sp new_fs)
        where
-         n1 = n+1
          new_fs = mkFastString (base ++ show n)
+         new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1)
+                     -- Update:  base_fs, so that next time we'll start whwere we left off
+                     --          new_fs,  so that we know it is taken
+                     -- If they are the same (n==1), the former wins
+                     -- See Note [TidyOccEnv]
 
 {-
 ************************************************************************

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

-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GADTs, BangPatterns #-}
 module CmmCommonBlockElim
   ( elimCommonBlocks
   )
@@ -9,6 +9,7 @@ import BlockId
 import Cmm
 import CmmUtils
 import CmmContFlowOpt
+-- import PprCmm ()
 import Prelude hiding (iterate, succ, unzip, zip)
 
 import Hoopl hiding (ChangeFlag)
@@ -19,9 +20,8 @@ import Data.Word
 import qualified Data.Map as M
 import Outputable
 import UniqFM
-
-my_trace :: String -> SDoc -> a -> a
-my_trace = if False then pprTrace else \_ _ a -> a
+import Unique
+import Control.Arrow (first, second)
 
 -- -----------------------------------------------------------------------------
 -- Eliminate common blocks
@@ -37,40 +37,72 @@ my_trace = if False then pprTrace else \_ _ a -> a
 -- is made redundant by the old block.
 -- Otherwise, it is added to the useful blocks.
 
+-- To avoid comparing every block with every other block repeatedly, we group
+-- them by
+--   * a hash of the block, ignoring labels (explained below)
+--   * the list of outgoing labels
+-- The hash is invariant under relabeling, so we only ever compare within
+-- the same group of blocks.
+--
+-- The list of outgoing labels is updated as we merge blocks (that is why they
+-- are not included in the hash, which we want to calculate only once).
+--
+-- All in all, two blocks should never be compared if they have different
+-- hashes, and at most once otherwise. Previously, we were slower, and people
+-- rightfully complained: #10397
+
 -- TODO: Use optimization fuel
 elimCommonBlocks :: CmmGraph -> CmmGraph
 elimCommonBlocks g = replaceLabels env $ copyTicks env g
   where
-     env = iterate hashed_blocks mapEmpty
-     hashed_blocks = map (\b -> (hash_block b, b)) $ postorderDfs g
-
--- Iterate over the blocks until convergence
-iterate :: [(HashCode,CmmBlock)] -> BlockEnv BlockId -> BlockEnv BlockId
-iterate blocks subst =
-  case foldl common_block (False, emptyUFM, subst) blocks of
-    (changed,  _, subst)
-       | changed   -> iterate blocks subst
-       | otherwise -> subst
+     env = iterate mapEmpty blocks_with_key
+     groups = groupByInt hash_block (postorderDfs g)
+     blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
+
+-- Invariant: The blocks in the list are pairwise distinct
+-- (so avoid comparing them again)
+type DistinctBlocks = [CmmBlock]
+type Key = [Label]
+type Subst = BlockEnv BlockId
+
+-- The outer list groups by hash. We retain this grouping throughout.
+iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
+iterate subst blocks
+    | mapNull new_substs = subst
+    | otherwise = iterate subst' updated_blocks
+  where
+    grouped_blocks :: [[(Key, [DistinctBlocks])]]
+    grouped_blocks = map groupByLabel blocks
 
-type State  = (ChangeFlag, UniqFM [CmmBlock], BlockEnv BlockId)
+    merged_blocks :: [[(Key, DistinctBlocks)]]
+    (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks
+      where
+        go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))
+          where
+            (new_subst2, db) = mergeBlockList subst dbs
 
-type ChangeFlag = Bool
-type HashCode = Int
+    subst' = subst `mapUnion` new_substs
+    updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
 
--- Try to find a block that is equal (or ``common'') to b.
-common_block :: State -> (HashCode, CmmBlock) -> State
-common_block (old_change, bmap, subst) (hash, b) =
-  case lookupUFM bmap hash of
-    Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
-                     mapLookup bid subst) of
-                 (Just b', Nothing)                         -> addSubst b'
-                 (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
-                                     | otherwise -> (old_change, bmap, subst)
-                 _ -> (old_change, addToUFM bmap hash (b : bs), subst)
-    Nothing -> (old_change, addToUFM bmap hash [b], subst)
-  where bid = entryLabel b
-        addSubst b' = my_trace "found new common block" (ppr bid <> char '=' <> ppr (entryLabel b')) $
-                      (True, bmap, mapInsert bid (entryLabel b') subst)
+mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
+mergeBlocks subst existing new = go new
+  where
+    go [] = (mapEmpty, existing)
+    go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of
+        -- This block is a duplicate. Drop it, and add it to the substitution
+        Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs
+        -- This block is not a duplicate, keep it.
+        Nothing -> second (b:) $ go bs
+
+mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)
+mergeBlockList _ [] = pprPanic "mergeBlockList" empty
+mergeBlockList subst (b:bs) = go mapEmpty b bs
+  where
+    go !new_subst1 b [] = (new_subst1, b)
+    go !new_subst1 b1 (b2:bs) = go new_subst b bs
+      where
+        (new_subst2, b) =  mergeBlocks subst b1 b2
+        new_subst = new_subst1 `mapUnion` new_subst2
 
 
 -- -----------------------------------------------------------------------------
@@ -79,9 +111,16 @@ common_block (old_change, bmap, subst) (hash, b) =
 -- Below here is mostly boilerplate: hashing blocks ignoring labels,
 -- and comparing blocks modulo a label mapping.
 
--- To speed up comparisons, we hash each basic block modulo labels.
+-- To speed up comparisons, we hash each basic block modulo jump labels.
 -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
 -- but it should be fast and good enough.
+
+-- We want to get as many small buckets as possible, as comparing blocks is
+-- expensive. So include as much as possible in the hash. Ideally everything
+-- that is compared with (==) in eqBlockBodyWith.
+
+type HashCode = Int
+
 hash_block :: CmmBlock -> HashCode
 hash_block block =
   fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
@@ -104,7 +143,7 @@ hash_block block =
         hash_node _ = error "hash_node: unknown Cmm node!"
 
         hash_reg :: CmmReg -> Word32
-        hash_reg   (CmmLocal _) = 117
+        hash_reg   (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397
         hash_reg   (CmmGlobal _)    = 19
 
         hash_e :: CmmExpr -> Word32
@@ -132,6 +171,9 @@ hash_block block =
 
         cvt = fromInteger . toInteger
 
+        hash_unique :: Uniquable a => a -> Word32
+        hash_unique = cvt . getKey . getUnique
+
 -- | Ignore these node types for equality
 dont_care :: CmmNode O x -> Bool
 dont_care CmmComment {}  = True
@@ -188,13 +230,18 @@ eqExprWith eqBid = eq
 -- IDs to block IDs.
 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
 eqBlockBodyWith eqBid block block'
-  = and (zipWith (eqMiddleWith eqBid) nodes nodes') &&
-    eqLastWith eqBid l l'
+  {-
+  | equal     = pprTrace "equal" (vcat [ppr block, ppr block']) True
+  | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False
+  -}
+  = equal
   where (_,m,l)   = blockSplit block
         nodes     = filter (not . dont_care) (blockToList m)
         (_,m',l') = blockSplit block'
         nodes'    = filter (not . dont_care) (blockToList m')
 
+        equal = and (zipWith (eqMiddleWith eqBid) nodes nodes') &&
+                eqLastWith eqBid l l'
 
 
 eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
@@ -237,3 +284,18 @@ copyTicks env g
               (CmmEntry lbl scp1, code) = blockSplitHead to
           in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`
              foldr blockCons code (map CmmTick ticks)
+
+-- Group by [Label]
+groupByLabel :: [(Key, a)] -> [(Key, [a])]
+groupByLabel = go M.empty
+  where
+    go !m [] = M.elems m
+    go !m ((k,v) : entries) = go (M.alter adjust k' m) entries
+      where k' = map getUnique k
+            adjust Nothing       = Just (k,[v])
+            adjust (Just (_,vs)) = Just (k,v:vs)
+
+
+groupByInt :: (a -> Int) -> [a] -> [[a]]
+groupByInt f xs = eltsUFM $ List.foldl' go emptyUFM xs
+  where go m x = alterUFM (Just . maybe [x] (x:)) m (f x)

compiler/cmm/CmmExpr.hs

@@ -20,7 +20,6 @@ module CmmExpr
     , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
     , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
     , regSetToList
-    , regUsedIn
 
     , Area(..)
     , module CmmMachOp
@@ -372,17 +371,6 @@ instance DefinerOfRegs r a => DefinerOfRegs r (Maybe a) where
   foldRegsDefd _      _ set Nothing  = set
   foldRegsDefd dflags f set (Just x) = foldRegsDefd dflags f set x
 
------------------------------------------------------------------------------
--- Another reg utility
-
-regUsedIn :: CmmReg -> CmmExpr -> Bool
-_   `regUsedIn` CmmLit _         = False
-reg `regUsedIn` CmmLoad e  _     = reg `regUsedIn` e
-reg `regUsedIn` CmmReg reg'      = reg == reg'
-reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
-reg `regUsedIn` CmmMachOp _ es   = any (reg `regUsedIn`) es
-_   `regUsedIn` CmmStackSlot _ _ = False
-
 -----------------------------------------------------------------------------
 --              Global STG registers
 -----------------------------------------------------------------------------
@@ -397,6 +385,31 @@ vgcFlag :: CmmType -> VGcPtr
 vgcFlag ty | isGcPtrType ty = VGcPtr
            | otherwise      = VNonGcPtr
 
+{-
+Note [Overlapping global registers]
+
+The backend might not faithfully implement the abstraction of the STG
+machine with independent registers for different values of type
+GlobalReg. Specifically, certain pairs of registers (r1, r2) may
+overlap in the sense that a store to r1 invalidates the value in r2,
+and vice versa.
+
+Currently this occurs only on the x86_64 architecture where FloatReg n
+and DoubleReg n are assigned the same microarchitectural register, in
+order to allow functions to receive more Float# or Double# arguments
+in registers (as opposed to on the stack).
+
+There are no specific rules about which registers might overlap with
+which other registers, but presumably it's safe to assume that nothing
+will overlap with special registers like Sp or BaseReg.
+
+Use CmmUtils.regsOverlap to determine whether two GlobalRegs overlap
+on a particular platform. The instance Eq GlobalReg is syntactic
+equality of STG registers and does not take overlap into
+account. However it is still used in UserOfRegs/DefinerOfRegs and
+there are likely still bugs there, beware!
+-}
+
 data GlobalReg
   -- Argument and return registers
   = VanillaReg                  -- pointers, unboxed ints and chars