compiler/main/HscTypes.hs

@@ -1200,12 +1200,11 @@ The details are a bit tricky though:
    It stays as 'main' (or whatever -this-package-key says), and is the
    package to which :load'ed modules are added to.
 
- * So how do we arrange that declarations at the command prompt get
-   to be in the 'interactive' package?  Simply by setting the tcg_mod
+ * So how do we arrange that declarations at the command prompt get to
+   be in the 'interactive' package?  Simply by setting the tcg_mod
    field of the TcGblEnv to "interactive:Ghci1".  This is done by the
-   call to initTc in initTcInteractive, initTcForLookup, which in
-   turn get the module from it 'icInteractiveModule' field of the
-   interactive context.
+   call to initTc in initTcInteractive, which in turn get the module
+   from it 'icInteractiveModule' field of the interactive context.
 
    The 'thisPackage' field stays as 'main' (or whatever -this-package-key says.
 
@@ -1403,8 +1402,9 @@ extendInteractiveContext :: InteractiveContext
                          -> [Id] -> [TyCon]
                          -> [ClsInst] -> [FamInst]
                          -> Maybe [Type]
+                         -> [PatSyn]
                          -> InteractiveContext
-extendInteractiveContext ictxt ids tcs new_cls_insts new_fam_insts defaults
+extendInteractiveContext ictxt ids tcs new_cls_insts new_fam_insts defaults new_patsyns
   = ictxt { ic_mod_index  = ic_mod_index ictxt + 1
                             -- Always bump this; even instances should create
                             -- a new mod_index (Trac #9426)
@@ -1413,7 +1413,7 @@ extendInteractiveContext ictxt ids tcs new_cls_insts new_fam_insts defaults
           , ic_instances  = (new_cls_insts ++ old_cls_insts, new_fam_insts ++ old_fam_insts)
           , ic_default    = defaults }
   where
-    new_tythings = map AnId ids ++ map ATyCon tcs
+    new_tythings = map AnId ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) new_patsyns
     old_tythings = filterOut (shadowed_by ids) (ic_tythings ictxt)
 
     -- Discard old instances that have been fully overrridden
@@ -1587,15 +1587,14 @@ mkQualPackage dflags pkg_key
         -- Skip the lookup if it's main, since it won't be in the package
         -- database!
      = False
-     | searchPackageId dflags pkgid `lengthIs` 1
+     | Just pkgid <- mb_pkgid
+     , searchPackageId dflags pkgid `lengthIs` 1
         -- this says: we are given a package pkg-0.1@MMM, are there only one
         -- exposed packages whose package ID is pkg-0.1?
      = False
      | otherwise
      = True
-     where pkg = fromMaybe (pprPanic "qual_pkg" (ftext (packageKeyFS pkg_key)))
-                    (lookupPackage dflags pkg_key)
-           pkgid = sourcePackageId pkg
+     where mb_pkgid = fmap sourcePackageId (lookupPackage dflags pkg_key)
 
 -- | A function which only qualifies package names if necessary; but
 -- qualifies all other identifiers.
@@ -2356,6 +2355,10 @@ data ModSummary
           -- ^ Timestamp of source file
         ms_obj_date     :: Maybe UTCTime,
           -- ^ Timestamp of object, if we have one
+        ms_iface_date   :: Maybe UTCTime,
+          -- ^ Timestamp of hi file, if we *only* are typechecking (it is
+          -- 'Nothing' otherwise.
+          -- See Note [Recompilation checking when typechecking only] and #9243
         ms_srcimps      :: [Located (ImportDecl RdrName)],
           -- ^ Source imports of the module
         ms_textual_imps :: [Located (ImportDecl RdrName)],
@@ -2382,6 +2385,7 @@ ms_imps ms =
     -- text, such as those induced by the use of plugins (the -plgFoo
     -- flag)
     mk_additional_import mod_nm = noLoc $ ImportDecl {
+      ideclSourceSrc = Nothing,
       ideclName      = noLoc mod_nm,
       ideclPkgQual   = Nothing,
       ideclSource    = False,

compiler/main/InteractiveEval.hs

@@ -950,9 +950,9 @@ greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 -- | Parses a string as an identifier, and returns the list of 'Name's that
 -- the identifier can refer to in the current interactive context.
 parseName :: GhcMonad m => String -> m [Name]
-parseName str = withSession $ \hsc_env -> do
-   (L _ rdr_name) <- liftIO $ hscParseIdentifier hsc_env str
-   liftIO $ hscTcRnLookupRdrName hsc_env rdr_name
+parseName str = withSession $ \hsc_env -> liftIO $
+   do { lrdr_name <- hscParseIdentifier hsc_env str
+      ; hscTcRnLookupRdrName hsc_env lrdr_name }
 
 -- -----------------------------------------------------------------------------
 -- Getting the type of an expression
@@ -991,6 +991,7 @@ dynCompileExpr :: GhcMonad m => String -> m Dynamic
 dynCompileExpr expr = do
     iis <- getContext
     let importDecl = ImportDecl {
+                         ideclSourceSrc = Nothing,
                          ideclName = noLoc (mkModuleName "Data.Dynamic"),
                          ideclPkgQual = Nothing,
                          ideclSource = False,

compiler/main/Packages.hs

@@ -355,9 +355,8 @@ getPackageConfRefs dflags = do
 resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
 resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
 resolvePackageConfig dflags UserPkgConf = handleIO (\_ -> return Nothing) $ do
-  appdir <- getAppUserDataDirectory (programName dflags)
-  let dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':projectVersion dflags)
-      pkgconf = dir </> "package.conf.d"
+  dir <- versionedAppDir dflags
+  let pkgconf = dir </> "package.conf.d"
   exist <- doesDirectoryExist pkgconf
   return $ if exist then Just pkgconf else Nothing
 resolvePackageConfig _ (PkgConfFile name) = return $ Just name
@@ -453,18 +452,6 @@ mungePackagePaths top_dir pkgroot pkg =
 -- Modify our copy of the package database based on a package flag
 -- (-package, -hide-package, -ignore-package).
 
--- | A horrible hack, the problem is the package key we'll turn
--- up here is going to get edited when we select the wired in
--- packages, so preemptively pick up the right one.  Also, this elem
--- test is slow.  The alternative is to change wired in packages first, but
--- then we are no longer able to match against package keys e.g. from when
--- a user passes in a package flag.
-calcKey :: PackageConfig -> PackageKey
-calcKey p | pk <- packageNameString p
-          , pk `elem` wired_in_pkgids
-                      = stringToPackageKey pk
-          | otherwise = packageConfigId p
-
 applyPackageFlag
    :: DynFlags
    -> UnusablePackages
@@ -485,7 +472,8 @@ applyPackageFlag dflags unusable (pkgs, vm) flag =
          Right (p:_,_) -> return (pkgs, vm')
           where
            n = fsPackageName p
-           vm' = addToUFM_C edit vm_cleared (calcKey p) (b, map convRn rns, n)
+           vm' = addToUFM_C edit vm_cleared (packageConfigId p)
+                            (b, map convRn rns, n)
            edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n)
            convRn (a,b) = (mkModuleName a, mkModuleName b)
            -- ToDo: ATM, -hide-all-packages implicitly triggers change in
@@ -493,7 +481,7 @@ applyPackageFlag dflags unusable (pkgs, vm) flag =
            -- flag
            vm_cleared | gopt Opt_HideAllPackages dflags = vm
                       | otherwise = filterUFM_Directly
-                            (\k (_,_,n') -> k == getUnique (calcKey p)
+                            (\k (_,_,n') -> k == getUnique (packageConfigId p)
                                                 || n /= n') vm
          _ -> panic "applyPackageFlag"
 
@@ -501,7 +489,7 @@ applyPackageFlag dflags unusable (pkgs, vm) flag =
        case selectPackages (matchingStr str) pkgs unusable of
          Left ps       -> packageFlagErr dflags flag ps
          Right (ps,_) -> return (pkgs, vm')
-          where vm' = delListFromUFM vm (map calcKey ps)
+          where vm' = delListFromUFM vm (map packageConfigId ps)
 
     -- we trust all matching packages. Maybe should only trust first one?
     -- and leave others the same or set them untrusted
@@ -605,9 +593,10 @@ wired_in_pkgids = map packageKeyString wiredInPackageKeys
 findWiredInPackages
    :: DynFlags
    -> [PackageConfig]           -- database
-   -> IO [PackageConfig]
+   -> VisibilityMap             -- info on what packages are visible
+   -> IO ([PackageConfig], VisibilityMap)
 
-findWiredInPackages dflags pkgs = do
+findWiredInPackages dflags pkgs vis_map = do
   --
   -- Now we must find our wired-in packages, and rename them to
   -- their canonical names (eg. base-1.0 ==> base).
@@ -622,18 +611,29 @@ findWiredInPackages dflags pkgs = do
         -- one.
         --
         -- When choosing which package to map to a wired-in package
-        -- name, we pick the latest version (modern Cabal makes it difficult
-        -- to install multiple versions of wired-in packages, however!)
-        -- To override the default choice, -ignore-package could be used to
-        -- hide newer versions.
+        -- name, we try to pick the latest version of exposed packages.
+        -- However, if there are no exposed wired in packages available
+        -- (e.g. -hide-all-packages was used), we can't bail: we *have*
+        -- to assign a package for the wired-in package: so we try again
+        -- with hidden packages included to (and pick the latest
+        -- version).
+        --
+        -- You can also override the default choice by using -ignore-package:
+        -- this works even when there is no exposed wired in package
+        -- available.
         --
         findWiredInPackage :: [PackageConfig] -> String
-                           -> IO (Maybe InstalledPackageId)
+                           -> IO (Maybe PackageConfig)
         findWiredInPackage pkgs wired_pkg =
-           let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in
-           case all_ps of
-                []   -> notfound
-                many -> pick (head (sortByVersion many))
+           let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
+               all_exposed_ps =
+                    [ p | p <- all_ps
+                        , elemUFM (packageConfigId p) vis_map ] in
+           case all_exposed_ps of
+            [] -> case all_ps of
+                       []   -> notfound
+                       many -> pick (head (sortByVersion many))
+            many -> pick (head (sortByVersion many))
           where
                 notfound = do
                           debugTraceMsg dflags 2 $
@@ -642,19 +642,20 @@ findWiredInPackages dflags pkgs = do
                                  <> ptext (sLit " not found.")
                           return Nothing
                 pick :: PackageConfig
-                     -> IO (Maybe InstalledPackageId)
+                     -> IO (Maybe PackageConfig)
                 pick pkg = do
                         debugTraceMsg dflags 2 $
                             ptext (sLit "wired-in package ")
                                  <> text wired_pkg
                                  <> ptext (sLit " mapped to ")
                                  <> ppr (installedPackageId pkg)
-                        return (Just (installedPackageId pkg))
+                        return (Just pkg)
 
 
-  mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids
+  mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids
   let
-        wired_in_ids = catMaybes mb_wired_in_ids
+        wired_in_pkgs = catMaybes mb_wired_in_pkgs
+        wired_in_ids = map installedPackageId wired_in_pkgs
 
         -- this is old: we used to assume that if there were
         -- multiple versions of wired-in packages installed that
@@ -678,7 +679,14 @@ findWiredInPackages dflags pkgs = do
                   | otherwise
                   = pkg
 
-  return $ updateWiredInDependencies pkgs
+        updateVisibilityMap vis_map = foldl' f vis_map wired_in_pkgs
+          where f vm p = case lookupUFM vis_map (packageConfigId p) of
+                            Nothing -> vm
+                            Just r -> addToUFM vm (stringToPackageKey
+                                                    (packageNameString p)) r
+
+
+  return (updateWiredInDependencies pkgs, updateVisibilityMap vis_map)
 
 -- ----------------------------------------------------------------------------
 
@@ -814,7 +822,8 @@ mkPackageState
            PackageKey) -- this package, might be modified if the current
                       -- package is a wired-in package.
 
-mkPackageState dflags pkgs0 preload0 this_package = do
+mkPackageState dflags0 pkgs0 preload0 this_package = do
+  dflags <- interpretPackageEnv dflags0
 
 {-
    Plan.
@@ -909,9 +918,9 @@ mkPackageState dflags pkgs0 preload0 this_package = do
       initial = if gopt Opt_HideAllPackages dflags
                     then emptyUFM
                     else foldl' calcInitial emptyUFM pkgs1
-      vis_map0 = foldUFM (\p vm ->
+      vis_map1 = foldUFM (\p vm ->
                             if exposed p
-                               then addToUFM vm (calcKey p)
+                               then addToUFM vm (packageConfigId p)
                                              (True, [], fsPackageName p)
                                else vm)
                          emptyUFM initial
@@ -922,15 +931,16 @@ mkPackageState dflags pkgs0 preload0 this_package = do
   -- This needs to know about the unusable packages, since if a user tries
   -- to enable an unusable package, we should let them know.
   --
-  (pkgs2, vis_map) <- foldM (applyPackageFlag dflags unusable)
-                            (pkgs1, vis_map0) other_flags
+  (pkgs2, vis_map2) <- foldM (applyPackageFlag dflags unusable)
+                            (pkgs1, vis_map1) other_flags
 
   --
   -- Sort out which packages are wired in. This has to be done last, since
   -- it modifies the package keys of wired in packages, but when we process
-  -- package arguments we need to key against the old versions.
+  -- package arguments we need to key against the old versions.  We also
+  -- have to update the visibility map in the process.
   --
-  pkgs3 <- findWiredInPackages dflags pkgs2
+  (pkgs3, vis_map) <- findWiredInPackages dflags pkgs2 vis_map2
 
   --
   -- Here we build up a set of the packages mentioned in -package
@@ -1315,12 +1325,10 @@ missingDependencyMsg (Just parent)
 
 -- -----------------------------------------------------------------------------
 
-packageKeyPackageIdString :: DynFlags -> PackageKey -> String
+packageKeyPackageIdString :: DynFlags -> PackageKey -> Maybe String
 packageKeyPackageIdString dflags pkg_key
-    | pkg_key == mainPackageKey = "main"
-    | otherwise = maybe "(unknown)"
-                      sourcePackageIdString
-                      (lookupPackage dflags pkg_key)
+    | pkg_key == mainPackageKey = Just "main"
+    | otherwise = fmap sourcePackageIdString (lookupPackage dflags pkg_key)
 
 -- | Will the 'Name' come from a dynamically linked library?
 isDllName :: DynFlags -> PackageKey -> Module -> Name -> Bool

compiler/main/Packages.hs-boot

@@ -3,4 +3,4 @@ module Packages where
 import {-# SOURCE #-} Module (PackageKey)
 import {-# SOURCE #-} DynFlags (DynFlags)
 data PackageState
-packageKeyPackageIdString :: DynFlags -> PackageKey -> String
+packageKeyPackageIdString :: DynFlags -> PackageKey -> Maybe String

compiler/main/StaticFlags.hs

-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, TupleSections #-}
 {-# OPTIONS_GHC -fno-cse #-}
 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
 
@@ -82,7 +82,10 @@ parseStaticFlagsFull flagsAvailable args = do
   when ready $ throwGhcExceptionIO (ProgramError "Too late for parseStaticFlags: call it before runGhc or runGhcT")
 
   (leftover, errs, warns) <- processArgs flagsAvailable args
-  when (not (null errs)) $ throwGhcExceptionIO $ errorsToGhcException errs
+
+  -- See Note [Handling errors when parsing commandline flags]
+  unless (null errs) $ throwGhcExceptionIO $
+      errorsToGhcException . map (("on the commandline", ) . unLoc) $ errs
 
     -- see sanity code in staticOpts
   writeIORef v_opt_C_ready True

compiler/main/SysTools.hs

@@ -40,11 +40,16 @@ module SysTools (
 
         -- Temporary-file management
         setTmpDir,
-        newTempName,
+        newTempName, newTempLibName,
         cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
         addFilesToClean,
 
-        Option(..)
+        Option(..),
+
+        -- frameworks
+        getPkgFrameworkOpts,
+        getFrameworkOpts
+
 
  ) where
 
@@ -221,6 +226,7 @@ initSysTools mbMinusB
                                  Just v -> return v
                                  Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)
                              Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
+       crossCompiling <- getBooleanSetting "cross compiling"
        targetArch <- readSetting "target arch"
        targetOS <- readSetting "target os"
        targetWordSize <- readSetting "target word size"
@@ -309,7 +315,8 @@ initSysTools mbMinusB
                           platformUnregisterised = targetUnregisterised,
                           platformHasGnuNonexecStack = targetHasGnuNonexecStack,
                           platformHasIdentDirective = targetHasIdentDirective,
-                          platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols
+                          platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols,
+                          platformIsCrossCompiling = crossCompiling
                       }
 
        return $ Settings {
@@ -405,7 +412,7 @@ runCc dflags args =   do
       args1 = map Option (getOpts dflags opt_c)
       args2 = args0 ++ args1 ++ args
   mb_env <- getGccEnv args2
-  runSomethingFiltered dflags cc_filter "C Compiler" p args2 mb_env
+  runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env
  where
   -- discard some harmless warnings from gcc that we can't turn off
   cc_filter = unlines . doFilter . lines
@@ -467,13 +474,14 @@ askCc dflags args = do
       args2 = args0 ++ args1 ++ args
   mb_env <- getGccEnv args2
   runSomethingWith dflags "gcc" p args2 $ \real_args ->
-    readCreateProcess (proc p real_args){ env = mb_env }
+    readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
 
--- Version of System.Process.readProcessWithExitCode that takes an environment
-readCreateProcess
+-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
+-- inherited from the parent process, and output to stderr is not captured.
+readCreateProcessWithExitCode'
     :: CreateProcess
     -> IO (ExitCode, String)    -- ^ stdout
-readCreateProcess proc = do
+readCreateProcessWithExitCode' proc = do
     (_, Just outh, _, pid) <-
         createProcess proc{ std_out = CreatePipe }
 
@@ -687,7 +695,7 @@ in terror).
 
 {- Note [Run-time linker info]
 
-See also: Trac #5240, Trac #6063
+See also: Trac #5240, Trac #6063, Trac #10110
 
 Before 'runLink', we need to be sure to get the relevant information
 about the linker we're using at runtime to see if we need any extra
@@ -716,6 +724,43 @@ circular dependency.
 
 -}
 
+{- Note [ELF needed shared libs]
+
+Some distributions change the link editor's default handling of
+ELF DT_NEEDED tags to include only those shared objects that are
+needed to resolve undefined symbols. For Template Haskell we need
+the last temporary shared library also if it is not needed for the
+currently linked temporary shared library. We specify --no-as-needed
+to override the default. This flag exists in GNU ld and GNU gold.
+
+The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
+(Mach-O) the flag is not needed.
+
+-}
+
+{- Note [Windows static libGCC]
+
+The GCC versions being upgraded to in #10726 are configured with
+dynamic linking of libgcc supported. This results in libgcc being
+linked dynamically when a shared library is created.
+
+This introduces thus an extra dependency on GCC dll that was not
+needed before by shared libraries created with GHC. This is a particular
+issue on Windows because you get a non-obvious error due to this missing
+dependency. This dependent dll is also not commonly on your path.
+
+For this reason using the static libgcc is preferred as it preserves
+the same behaviour that existed before. There are however some very good
+reasons to have the shared version as well as described on page 181 of
+https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf :
+
+"There are several situations in which an application should use the
+ shared ‘libgcc’ instead of the static version. The most common of these
+ is when the application wishes to throw and catch exceptions across different
+ shared libraries. In that case, each of the libraries as well as the application
+ itself should use the shared ‘libgcc’. "
+
+-}
 
 neededLinkArgs :: LinkerInfo -> [Option]
 neededLinkArgs (GnuLD o)     = o
@@ -750,12 +795,17 @@ getLinkerInfo' dflags = do
         | any ("GNU ld" `isPrefixOf`) stdo =
           -- GNU ld specifically needs to use less memory. This especially
           -- hurts on small object files. Trac #5240.
+          -- Set DT_NEEDED for all shared libraries. Trac #10110.
           return (GnuLD $ map Option ["-Wl,--hash-size=31",
-                                      "-Wl,--reduce-memory-overheads"])
+                                      "-Wl,--reduce-memory-overheads",
+                                      -- ELF specific flag
+                                      -- see Note [ELF needed shared libs]
+                                      "-Wl,--no-as-needed"])
 
         | any ("GNU gold" `isPrefixOf`) stdo =
-          -- GNU gold does not require any special arguments.
-          return (GnuGold [])
+          -- GNU gold only needs --no-as-needed. Trac #10110.
+          -- ELF specific flag, see Note [ELF needed shared libs]
+          return (GnuGold [Option "-Wl,--no-as-needed"])
 
          -- Unknown linker.
         | otherwise = fail "invalid --version output, or linker is unsupported"
@@ -789,7 +839,9 @@ getLinkerInfo' dflags = do
                    , "-Wl,--reduce-memory-overheads"
                      -- Increase default stack, see
                      -- Note [Windows stack usage]
-                   , "-Xlinker", "--stack=0x800000,0x800000" ]
+                     -- Force static linking of libGCC
+                     -- Note [Windows static libGCC]
+                   , "-Xlinker", "--stack=0x800000,0x800000", "-static-libgcc" ]
                _ -> do
                  -- In practice, we use the compiler as the linker here. Pass
                  -- -Wl,--version to get linker version info.
@@ -872,9 +924,9 @@ runLink dflags args = do
   linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
   let (p,args0) = pgm_l dflags
       args1     = map Option (getOpts dflags opt_l)
-      args2     = args0 ++ args1 ++ args ++ linkargs
+      args2     = args0 ++ linkargs ++ args1 ++ args
   mb_env <- getGccEnv args2
-  runSomethingFiltered dflags ld_filter "Linker" p args2 mb_env
+  runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env
   where
     ld_filter = case (platformOS (targetPlatform dflags)) of
                   OSSolaris2 -> sunos_ld_filter
@@ -1062,8 +1114,7 @@ newTempSuffix dflags = atomicModifyIORef (nextTempSuffix dflags) $ \n -> (n+1,n)
 newTempName :: DynFlags -> Suffix -> IO FilePath
 newTempName dflags extn
   = do d <- getTempDir dflags
-       x <- getProcessID
-       findTempName (d </> "ghc" ++ show x ++ "_")
+       findTempName (d </> "ghc_") -- See Note [Deterministic base name]
   where
     findTempName :: FilePath -> IO FilePath
     findTempName prefix
@@ -1075,6 +1126,23 @@ newTempName dflags extn
                         consIORef (filesToClean dflags) filename
                         return filename
 
+newTempLibName :: DynFlags -> Suffix -> IO (FilePath, FilePath, String)
+newTempLibName dflags extn
+  = do d <- getTempDir dflags
+       findTempName d ("ghc_")
+  where
+    findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
+    findTempName dir prefix
+      = do n <- newTempSuffix dflags -- See Note [Deterministic base name]
+           let libname = prefix ++ show n
+               filename = dir </> "lib" ++ libname <.> extn
+           b <- doesFileExist filename
+           if b then findTempName dir prefix
+                else do -- clean it up later
+                        consIORef (filesToClean dflags) filename
+                        return (filename, dir, libname)
+
+
 -- Return our temporary directory within tmp_dir, creating one if we
 -- don't have one yet.
 getTempDir :: DynFlags -> IO FilePath
@@ -1118,6 +1186,17 @@ getTempDir dflags = do
       `catchIO` \e -> if isAlreadyExistsError e
                       then mkTempDir prefix else ioError e
 
+-- Note [Deterministic base name]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- The filename of temporary files, especially the basename of C files, can end
+-- up in the output in some form, e.g. as part of linker debug information. In the
+-- interest of bit-wise exactly reproducible compilation (#4012), the basename of
+-- the temporary file no longer contains random information (it used to contain
+-- the process id).
+--
+-- This is ok, as the temporary directory used contains the pid (see getTempDir).
+
 addFilesToClean :: DynFlags -> [FilePath] -> IO ()
 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 addFilesToClean dflags new_files
@@ -1175,6 +1254,58 @@ runSomething :: DynFlags
 runSomething dflags phase_name pgm args =
   runSomethingFiltered dflags id phase_name pgm args Nothing
 
+-- | Run a command, placing the arguments in an external response file.
+--
+-- This command is used in order to avoid overlong command line arguments on
+-- Windows. The command line arguments are first written to an external,
+-- temporary response file, and then passed to the linker via @filepath.
+-- response files for passing them in. See:
+--
+--     https://gcc.gnu.org/wiki/Response_Files
+--     https://ghc.haskell.org/trac/ghc/ticket/10777
+runSomethingResponseFile
+  :: DynFlags -> (String->String) -> String -> String -> [Option]
+  -> Maybe [(String,String)] -> IO ()
+
+runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =
+    runSomethingWith dflags phase_name pgm args $ \real_args -> do
+        fp <- getResponseFile real_args
+        let args = ['@':fp]
+        r <- builderMainLoop dflags filter_fn pgm args mb_env
+        return (r,())
+  where
+    getResponseFile args = do
+      fp <- newTempName dflags "rsp"
+      withFile fp WriteMode $ \h -> do
+          hSetEncoding h utf8
+          hPutStr h $ unlines $ map escape args
+      return fp
+
+    -- Note: Response files have backslash-escaping, double quoting, and are
+    -- whitespace separated (some implementations use newline, others any
+    -- whitespace character). Therefore, escape any backslashes, newlines, and
+    -- double quotes in the argument, and surround the content with double
+    -- quotes.
+    --
+    -- Another possibility that could be considered would be to convert
+    -- backslashes in the argument to forward slashes. This would generally do
+    -- the right thing, since backslashes in general only appear in arguments
+    -- as part of file paths on Windows, and the forward slash is accepted for
+    -- those. However, escaping is more reliable, in case somehow a backslash
+    -- appears in a non-file.
+    escape x = concat
+        [ "\""
+        , concatMap
+            (\c ->
+                case c of
+                    '\\' -> "\\\\"
+                    '\n' -> "\\n"
+                    '\"' -> "\\\""
+                    _    -> [c])
+            x
+        , "\""
+        ]
+
 runSomethingFiltered
   :: DynFlags -> (String->String) -> String -> String -> [Option]
   -> Maybe [(String,String)] -> IO ()
@@ -1470,6 +1601,11 @@ linkDynLib dflags0 o_files dep_packages
         -- and last temporary shared object file
     let extra_ld_inputs = ldInputs dflags
 
+    -- frameworks
+    pkg_framework_opts <- getPkgFrameworkOpts dflags platform
+                                              (map packageKey pkgs)
+    let framework_opts = getFrameworkOpts dflags platform
+
     case os of
         OSMinGW32 -> do
             -------------------------------------------------------------
@@ -1555,8 +1691,10 @@ linkDynLib dflags0 o_files dep_packages
                  ++ [ Option "-install_name", Option instName ]
                  ++ map Option lib_path_opts
                  ++ extra_ld_inputs
+                 ++ map Option framework_opts
                  ++ map Option pkg_lib_path_opts
                  ++ map Option pkg_link_opts
+                 ++ map Option pkg_framework_opts
               )
         OSiOS -> throwGhcExceptionIO (ProgramError "dynamic libraries are not supported on iOS target")
         _ -> do
@@ -1590,3 +1728,31 @@ linkDynLib dflags0 o_files dep_packages
                  ++ map Option pkg_lib_path_opts
                  ++ map Option pkg_link_opts
               )
+
+getPkgFrameworkOpts :: DynFlags -> Platform -> [PackageKey] -> IO [String]
+getPkgFrameworkOpts dflags platform dep_packages
+  | platformUsesFrameworks platform = do
+    pkg_framework_path_opts <- do
+        pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
+        return $ map ("-F" ++) pkg_framework_paths
+
+    pkg_framework_opts <- do
+        pkg_frameworks <- getPackageFrameworks dflags dep_packages
+        return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]
+
+    return (pkg_framework_path_opts ++ pkg_framework_opts)
+
+  | otherwise = return []
+
+getFrameworkOpts :: DynFlags -> Platform -> [String]
+getFrameworkOpts dflags platform
+  | platformUsesFrameworks platform = framework_path_opts ++ framework_opts
+  | otherwise = []
+  where
+    framework_paths     = frameworkPaths dflags
+    framework_path_opts = map ("-F" ++) framework_paths
+
+    frameworks     = cmdlineFrameworks dflags
+    -- reverse because they're added in reverse order from the cmd line:
+    framework_opts = concat [ ["-framework", fw]
+                            | fw <- reverse frameworks ]

compiler/nativeGen/AsmCodeGen.hs

@@ -63,6 +63,7 @@ import UniqFM
 import UniqSupply
 import DynFlags
 import Util
+import Unique
 
 import BasicTypes       ( Alignment )
 import Digraph
@@ -81,6 +82,7 @@ import qualified Stream
 
 import Data.List
 import Data.Maybe
+import Data.Ord         ( comparing )
 import Control.Exception
 #if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
@@ -427,12 +429,15 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us
              cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap
                           cmm count
 
-        let newFileIds = fileIds' `minusUFM` fileIds
+        -- Generate .file directives for every new file that has been
+        -- used. Note that it is important that we generate these in
+        -- ascending order, as Clang's 3.6 assembler complains.
+        let newFileIds = sortBy (comparing snd) $ eltsUFM $ fileIds' `minusUFM` fileIds
             pprDecl (f,n) = ptext (sLit "\t.file ") <> ppr n <+>
                             doubleQuotes (ftext f)
 
         emitNativeCode dflags h $ vcat $
-          map pprDecl (eltsUFM newFileIds) ++
+          map pprDecl newFileIds ++
           map (pprNatCmmDecl ncgImpl) native
 
         -- force evaluation all this stuff to avoid space leaks
@@ -779,25 +784,41 @@ mkNode block@(BasicBlock id instrs) = (block, id, getOutEdges instrs)
 
 seqBlocks :: BlockEnv i -> [(GenBasicBlock t1, BlockId, [BlockId])]
                         -> [GenBasicBlock t1]
-seqBlocks _ [] = []
-seqBlocks infos ((block,_,[]) : rest)
-  = block : seqBlocks infos rest
-seqBlocks infos ((block@(BasicBlock id instrs),_,[next]) : rest)
-  | can_fallthrough = BasicBlock id (init instrs) : seqBlocks infos rest'
-  | otherwise       = block : seqBlocks infos rest'
+seqBlocks infos blocks = placeNext pullable0 todo0
   where
-        can_fallthrough = not (mapMember next infos) && can_reorder
-        (can_reorder, rest') = reorder next [] rest
-          -- TODO: we should do a better job for cycles; try to maximise the
-          -- fallthroughs within a loop.
-seqBlocks _ _ = panic "AsmCodegen:seqBlocks"
-
-reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
-reorder  _ accum [] = (False, reverse accum)
-reorder id accum (b@(block,id',out) : rest)
-  | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
-  | otherwise  = reorder id (b:accum) rest
-
+    -- pullable: Blocks that are not yet placed
+    -- todo:     Original order of blocks, to be followed if we have no good
+    --           reason not to;
+    --           may include blocks that have already been placed, but then
+    --           these are not in pullable
+    pullable0 = listToUFM [ (i,(b,n)) | (b,i,n) <- blocks ]
+    todo0     = [i | (_,i,_) <- blocks ]
+
+    placeNext _ [] = []
+    placeNext pullable (i:rest)
+        | Just (block, pullable') <- lookupDeleteUFM pullable i
+        = place pullable' rest block
+        | otherwise
+        -- We already placed this block, so ignore
+        = placeNext pullable rest
+
+    place pullable todo (block,[])
+                          = block : placeNext pullable todo
+    place pullable todo (block@(BasicBlock id instrs),[next])
+        | mapMember next infos
+        = block : placeNext pullable todo
+        | Just (nextBlock, pullable') <- lookupDeleteUFM pullable next
+        = BasicBlock id (init instrs) : place pullable' todo nextBlock
+        | otherwise
+        = block : placeNext pullable todo
+    place _ _ (_,tooManyNextNodes)
+        = pprPanic "seqBlocks" (ppr tooManyNextNodes)
+
+
+lookupDeleteUFM :: Uniquable key => UniqFM elt -> key -> Maybe (elt, UniqFM elt)
+lookupDeleteUFM m k = do -- Maybe monad
+    v <- lookupUFM m k
+    return (v, delFromUFM m k)
 
 -- -----------------------------------------------------------------------------
 -- Generate jump tables

compiler/nativeGen/Dwarf.hs

@@ -33,10 +33,13 @@ dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
 dwarfGen df modLoc us blocks = do
 
   -- Convert debug data structures to DWARF info records
+  -- We strip out block information, as it is not currently useful for
+  -- anything. In future we might want to only do this for -g1.
   let procs = debugSplitProcs blocks
+      stripBlocks dbg = dbg { dblBlocks = [] }
   compPath <- getCurrentDirectory
   let dwarfUnit = DwarfCompileUnit
-        { dwChildren = map (procToDwarf df) procs
+        { dwChildren = map (procToDwarf df) (map stripBlocks procs)
         , dwName = fromMaybe "" (ml_hs_file modLoc)
         , dwCompDir = addTrailingPathSeparator compPath
         , dwProducer = cProjectName ++ " " ++ cProjectVersion
@@ -83,7 +86,7 @@ compileUnitHeader unitU = sdocWithPlatform $ \plat ->
   in vcat [ ptext (sLit "\t.long ") <> length  -- compilation unit size
           , ppr cuLabel <> colon
           , ptext (sLit "\t.word 3")           -- DWARF version
-          , pprDwWord (sectionOffset dwarfAbbrevLabel dwarfAbbrevLabel)
+          , sectionOffset dwarfAbbrevLabel dwarfAbbrevLabel
                                                -- abbrevs offset
           , ptext (sLit "\t.byte ") <> ppr (platformWordSize plat) -- word size
           ]

compiler/nativeGen/Dwarf/Constants.hs

@@ -41,7 +41,7 @@ dW_TAG_arg_variable    = 257
 -- | Dwarf attributes
 dW_AT_name, dW_AT_stmt_list, dW_AT_low_pc, dW_AT_high_pc, dW_AT_language,
   dW_AT_comp_dir, dW_AT_producer, dW_AT_external, dW_AT_frame_base,
-  dW_AT_MIPS_linkage_name :: Word
+  dW_AT_use_UTF8, dW_AT_MIPS_linkage_name :: Word
 dW_AT_name              = 0x03
 dW_AT_stmt_list         = 0x10
 dW_AT_low_pc            = 0x11
@@ -51,6 +51,7 @@ dW_AT_comp_dir          = 0x1b
 dW_AT_producer          = 0x25
 dW_AT_external          = 0x3f
 dW_AT_frame_base        = 0x40
+dW_AT_use_UTF8          = 0x53
 dW_AT_MIPS_linkage_name = 0x2007
 
 -- | Abbrev declaration
@@ -121,12 +122,14 @@ dwarfFrameSection  = dwarfSection "frame"
 dwarfGhcSection    = dwarfSection "ghc"
 
 dwarfSection :: String -> SDoc
-dwarfSection name = sdocWithPlatform $ \plat ->
+dwarfSection name = sdocWithPlatform $ \plat -> ftext $ mkFastString $
   case platformOS plat of
-    OSDarwin -> ftext $ mkFastString $
-                  ".section __DWARF,__debug_" ++ name ++ ",regular,debug"
-    _other   -> ftext $ mkFastString $
-                  ".section .debug_" ++ name ++ ",\"\",@progbits"
+    os | osElfTarget os
+       -> "\t.section .debug_" ++ name ++ ",\"\",@progbits"
+       | osMachOTarget os
+       -> "\t.section __DWARF,__debug_" ++ name ++ ",regular,debug"
+       | otherwise
+       -> "\t.section .debug_" ++ name ++ ",\"dr\""
 
 -- | Dwarf section labels
 dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: LitString

compiler/nativeGen/Dwarf/Types.hs

@@ -21,6 +21,7 @@ module Dwarf.Types
 import Debug
 import CLabel
 import CmmExpr         ( GlobalReg(..) )
+import Encoding
 import FastString
 import Outputable
 import Platform
@@ -79,6 +80,7 @@ pprAbbrevDecls haveDebugLine =
        , (dW_AT_producer, dW_FORM_string)
        , (dW_AT_language, dW_FORM_data4)
        , (dW_AT_comp_dir, dW_FORM_string)
+       , (dW_AT_use_UTF8, dW_FORM_flag)
        ] ++
        (if haveDebugLine
         then [ (dW_AT_stmt_list, dW_FORM_data4) ]
@@ -115,8 +117,9 @@ pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lineLbl) =
   $$ pprString producer
   $$ pprData4 dW_LANG_Haskell
   $$ pprString compDir
+  $$ pprFlag True -- use UTF8
   $$ if haveSrc
-     then pprData4' (sectionOffset lineLbl dwarfLineLabel)
+     then sectionOffset lineLbl dwarfLineLabel
      else empty
 pprDwarfInfoOpen _ (DwarfSubprogram _ name label) = sdocWithDynFlags $ \df ->
   pprAbbrev DwAbbrSubprogram
@@ -406,27 +409,35 @@ pprString' str = ptext (sLit "\t.asciz \"") <> str <> char '"'
 
 -- | Generate a string constant. We take care to escape the string.
 pprString :: String -> SDoc
-pprString = pprString' . hcat . map escape
-  where escape '\\' = ptext (sLit "\\\\")
-        escape '\"' = ptext (sLit "\\\"")
-        escape '\n' = ptext (sLit "\\n")
-        escape c    | isAscii c && isPrint c && c /= '?'
-                      -- escaping '?' prevents trigraph warnings
-                    = char c
-                    | otherwise
-                    = let ch = ord c
-                      in char '\\' <>
-                         char (intToDigit (ch `div` 64)) <>
-                         char (intToDigit ((ch `div` 8) `mod` 8)) <>
-                         char (intToDigit (ch `mod` 8))
+pprString str
+  = pprString' $ hcat $ map escapeChar $
+    if utf8EncodedLength str == length str
+    then str
+    else map (chr . fromIntegral) $ bytesFS $ mkFastString str
+
+-- | Escape a single non-unicode character
+escapeChar :: Char -> SDoc
+escapeChar '\\' = ptext (sLit "\\\\")
+escapeChar '\"' = ptext (sLit "\\\"")
+escapeChar '\n' = ptext (sLit "\\n")
+escapeChar c
+  | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings
+  = char c
+  | otherwise
+  = char '\\' <> char (intToDigit (ch `div` 64)) <>
+                 char (intToDigit ((ch `div` 8) `mod` 8)) <>
+                 char (intToDigit (ch `mod` 8))
+  where ch = ord c
 
 -- | Generate an offset into another section. This is tricky because
 -- this is handled differently depending on platform: Mac Os expects
--- us to calculate the offset using assembler arithmetic. Meanwhile,
--- GNU tools expect us to just reference the target directly, and will
--- figure out on their own that we actually need an offset.
+-- us to calculate the offset using assembler arithmetic. Linux expects
+-- us to just reference the target directly, and will figure out on
+-- their own that we actually need an offset. Finally, Windows has
+-- a special directive to refer to relative offsets. Fun.
 sectionOffset :: LitString -> LitString -> SDoc
 sectionOffset target section = sdocWithPlatform $ \plat ->
   case platformOS plat of
-    OSDarwin -> ptext target <> char '-' <> ptext section
-    _other   -> ptext target
+    OSDarwin  -> pprDwWord (ptext target <> char '-' <> ptext section)
+    OSMinGW32 -> text "\t.secrel32 " <> ptext target
+    _other    -> pprDwWord (ptext target)

compiler/nativeGen/PPC/Instr.hs

@@ -74,15 +74,13 @@ instance Instruction Instr where
 ppc_mkStackAllocInstr :: Platform -> Int -> Instr
 ppc_mkStackAllocInstr platform amount
   = case platformArch platform of
-      ArchPPC -> -- SUB II32 (OpImm (ImmInt amount)) (OpReg esp)
-                 ADD sp sp (RIImm (ImmInt (-amount)))
+      ArchPPC -> UPDATE_SP II32 (ImmInt (-amount))
       arch -> panic $ "ppc_mkStackAllocInstr " ++ show arch
 
 ppc_mkStackDeallocInstr :: Platform -> Int -> Instr
 ppc_mkStackDeallocInstr platform amount
   = case platformArch platform of
-      ArchPPC -> -- ADD II32 (OpImm (ImmInt amount)) (OpReg esp)
-                 ADD sp sp (RIImm (ImmInt amount))
+      ArchPPC -> UPDATE_SP II32 (ImmInt amount)
       arch -> panic $ "ppc_mkStackDeallocInstr " ++ show arch
 
 --
@@ -183,8 +181,10 @@ data Instr
 
     -- Loads and stores.
     | LD      Size Reg AddrMode     -- Load size, dst, src
+    | LDFAR   Size Reg AddrMode     -- Load format, dst, src 32 bit offset
     | LA      Size Reg AddrMode     -- Load arithmetic size, dst, src
     | ST      Size Reg AddrMode     -- Store size, src, dst
+    | STFAR   Size Reg AddrMode     -- Store format, src, dst 32 bit offset
     | STU     Size Reg AddrMode     -- Store with Update size, src, dst
     | LIS     Reg Imm               -- Load Immediate Shifted dst, src
     | LI      Reg Imm               -- Load Immediate dst, src
@@ -258,6 +258,9 @@ data Instr
 
     | LWSYNC                    -- memory barrier
 
+    | UPDATE_SP Size Imm        -- expand/shrink spill area on C stack
+                                -- pseudo-instruction
+
 
 -- | Get the registers that are being used by this instruction.
 -- regUsage doesn't need to do any trickery for jumps and such.
@@ -269,8 +272,10 @@ ppc_regUsageOfInstr :: Platform -> Instr -> RegUsage
 ppc_regUsageOfInstr platform instr
  = case instr of
     LD      _ reg addr       -> usage (regAddr addr, [reg])
+    LDFAR   _ reg addr       -> usage (regAddr addr, [reg])
     LA      _ reg addr       -> usage (regAddr addr, [reg])
     ST      _ reg addr       -> usage (reg : regAddr addr, [])
+    STFAR   _ reg addr       -> usage (reg : regAddr addr, [])
     STU     _ reg addr       -> usage (reg : regAddr addr, [])
     LIS     reg _            -> usage ([], [reg])
     LI      reg _            -> usage ([], [reg])
@@ -321,6 +326,7 @@ ppc_regUsageOfInstr platform instr
     MFCR    reg             -> usage ([], [reg])
     MFLR    reg             -> usage ([], [reg])
     FETCHPC reg             -> usage ([], [reg])
+    UPDATE_SP _ _           -> usage ([], [sp])
     _                       -> noUsage
   where
     usage (src, dst) = RU (filter (interesting platform) src)
@@ -347,8 +353,10 @@ ppc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
 ppc_patchRegsOfInstr instr env
  = case instr of
     LD      sz reg addr     -> LD sz (env reg) (fixAddr addr)
+    LDFAR   fmt reg addr    -> LDFAR fmt (env reg) (fixAddr addr)
     LA      sz reg addr     -> LA sz (env reg) (fixAddr addr)
     ST      sz reg addr     -> ST sz (env reg) (fixAddr addr)
+    STFAR   fmt reg addr    -> STFAR fmt (env reg) (fixAddr addr)
     STU     sz reg addr     -> STU sz (env reg) (fixAddr addr)
     LIS     reg imm         -> LIS (env reg) imm
     LI      reg imm         -> LI (env reg) imm
@@ -464,8 +472,10 @@ ppc_mkSpillInstr dflags reg delta slot
                 RcInteger -> II32
                 RcDouble  -> FF64
                 _      -> panic "PPC.Instr.mkSpillInstr: no match"
-    in ST sz reg (AddrRegImm sp (ImmInt (off-delta)))
-
+        instr = case makeImmediate W32 True (off-delta) of
+                   Just _  -> ST
+                   Nothing -> STFAR -- pseudo instruction: 32 bit offsets
+    in instr sz reg (AddrRegImm sp (ImmInt (off-delta)))
 
 ppc_mkLoadInstr
    :: DynFlags
@@ -482,7 +492,10 @@ ppc_mkLoadInstr dflags reg delta slot
                 RcInteger -> II32
                 RcDouble  -> FF64
                 _         -> panic "PPC.Instr.mkLoadInstr: no match"
-    in LD sz reg (AddrRegImm sp (ImmInt (off-delta)))
+        instr = case makeImmediate W32 True (off-delta) of
+                Just _  -> LD
+                Nothing -> LDFAR -- pseudo instruction: 32 bit offsets
+    in instr sz reg (AddrRegImm sp (ImmInt (off-delta)))
 
 
 -- | The maximum number of bytes required to spill a register. PPC32

compiler/nativeGen/PPC/Ppr.hs

@@ -376,6 +376,16 @@ pprInstr (LD sz reg addr) = hcat [
         ptext (sLit ", "),
         pprAddr addr
     ]
+
+pprInstr (LDFAR fmt reg (AddrRegImm source off)) =
+   sdocWithPlatform $ \platform -> vcat [
+         pprInstr (ADDIS (tmpReg platform) source (HA off)),
+         pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off)))
+    ]
+
+pprInstr (LDFAR _ _ _) =
+   panic "PPC.Ppr.pprInstr LDFAR: no match"
+
 pprInstr (LA sz reg addr) = hcat [
         char '\t',
         ptext (sLit "l"),
@@ -405,6 +415,13 @@ pprInstr (ST sz reg addr) = hcat [
         ptext (sLit ", "),
         pprAddr addr
     ]
+pprInstr (STFAR fmt reg (AddrRegImm source off)) =
+   sdocWithPlatform $ \platform -> vcat [
+         pprInstr (ADDIS (tmpReg platform) source (HA off)),
+         pprInstr (ST fmt reg (AddrRegImm (tmpReg platform) (LO off)))
+    ]
+pprInstr (STFAR _ _ _) =
+   panic "PPC.Ppr.pprInstr STFAR: no match"
 pprInstr (STU sz reg addr) = hcat [
         char '\t',
         ptext (sLit "st"),
@@ -607,14 +624,22 @@ pprInstr (EXTS sz reg1 reg2) = hcat [
 pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
 pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
 
-pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri)
 
-pprInstr (SRW reg1 reg2 (RIImm (ImmInt i))) | i > 31 || i < 0 =
+pprInstr (SRW reg1 reg2 (RIImm (ImmInt i))) | i < 0  || i > 31 =
     -- Handle the case where we are asked to shift a 32 bit register by
     -- less than zero or more than 31 bits. We convert this into a clear
     -- of the destination register.
     -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/5900
     pprInstr (XOR reg1 reg2 (RIReg reg2))
+
+pprInstr (SLW reg1 reg2 (RIImm (ImmInt i))) | i < 0  || i > 31 =
+    -- As aboce for SR, but for left shifts.
+    -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/10870
+    pprInstr (XOR reg1 reg2 (RIReg reg2))
+
+
+pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri)
+
 pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri)
 
 pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri)
@@ -681,6 +706,22 @@ pprInstr (FETCHPC reg) = vcat [
 
 pprInstr LWSYNC = ptext (sLit "\tlwsync")
 
+pprInstr (UPDATE_SP fmt amount@(ImmInt offset))
+   | fits16Bits offset = vcat [
+       pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))),
+       pprInstr (STU fmt r0 (AddrRegImm sp amount))
+     ]
+
+pprInstr (UPDATE_SP fmt amount)
+   = sdocWithPlatform $ \platform ->
+       let tmp = tmpReg platform in
+         vcat [
+           pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))),
+           pprInstr (ADDIS tmp sp (HA amount)),
+           pprInstr (ADD tmp tmp (RIImm (LO amount))),
+           pprInstr (STU fmt r0 (AddrRegReg sp tmp))
+         ]
+
 -- pprInstr _ = panic "pprInstr (ppc)"
 
 

compiler/nativeGen/PPC/Regs.hs

@@ -37,7 +37,8 @@ module PPC.Regs (
         fits16Bits,
         makeImmediate,
         fReg,
-        sp, r3, r4, r27, r28, r30,
+        r0, sp, r3, r4, r27, r28, r30,
+        tmpReg,
         f1, f20, f21,
 
         allocatableRegs
@@ -296,7 +297,8 @@ point registers.
 fReg :: Int -> RegNo
 fReg x = (32 + x)
 
-sp, r3, r4, r27, r28, r30, f1, f20, f21 :: Reg
+r0, sp, r3, r4, r27, r28, r30, f1, f20, f21 :: Reg
+r0      = regSingle 0
 sp      = regSingle 1
 r3      = regSingle 3
 r4      = regSingle 4
@@ -314,3 +316,10 @@ allocatableRegs :: Platform -> [RealReg]
 allocatableRegs platform
    = let isFree i = isFastTrue (freeReg platform i)
      in  map RealRegSingle $ filter isFree allMachRegNos
+
+-- temporary register for compiler use
+tmpReg :: Platform -> Reg
+tmpReg platform =
+       case platformArch platform of
+       ArchPPC      -> regSingle 13
+       _            -> panic "PPC.Regs.tmpReg: unknowm arch"

compiler/parser/ApiAnnotation.hs

 {-# LANGUAGE DeriveDataTypeable #-}
 
 module ApiAnnotation (
-  getAnnotation,
-  getAnnotationComments,
+  getAnnotation, getAndRemoveAnnotation,
+  getAnnotationComments,getAndRemoveAnnotationComments,
   ApiAnns,
   ApiAnnKey,
   AnnKeywordId(..),
@@ -17,9 +17,9 @@ import qualified Data.Map as Map
 import Data.Data
 
 
-{- Note [Api annotations]
-   ~~~~~~~~~~~~~~~~~~~~~~
-
+{-
+Note [Api annotations]
+~~~~~~~~~~~~~~~~~~~~~~
 In order to do source to source conversions using the GHC API, the
 locations of all elements of the original source needs to be tracked.
 The includes keywords such as 'let' / 'in' / 'do' etc as well as
@@ -66,8 +66,8 @@ This is done in the lexer / parser as follows.
 
 The PState variable in the lexer has the following variables added
 
->  annotations :: [(ApiAnnKey,SrcSpan)],
->  comment_q :: [Located Token],
+>  annotations :: [(ApiAnnKey,[SrcSpan])],
+>  comment_q :: [Located AnnotationComment],
 >  annotations_comments :: [(SrcSpan,[Located AnnotationComment])]
 
 The first and last store the values that end up in the ApiAnns value
@@ -115,6 +115,9 @@ This adds an AnnLet annotation for 'let', an AnnIn for 'in', as well
 as any annotations that may arise in the binds. This will include open
 and closing braces if they are used to delimit the let expressions.
 
+The wiki page describing this feature is
+https://ghc.haskell.org/trac/ghc/wiki/ApiAnnotations
+
 -}
 -- ---------------------------------------------------------------------
 
@@ -132,28 +135,68 @@ getAnnotation (anns,_) span ann
        Nothing -> []
        Just ss -> ss
 
+-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan'
+-- of the annotated AST element, and the known type of the annotation.
+-- The list is removed from the annotations.
+getAndRemoveAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId
+                       -> ([SrcSpan],ApiAnns)
+getAndRemoveAnnotation (anns,cs) span ann
+   = case Map.lookup (span,ann) anns of
+       Nothing -> ([],(anns,cs))
+       Just ss -> (ss,(Map.delete (span,ann) anns,cs))
+
 -- |Retrieve the comments allocated to the current 'SrcSpan'
+--
+--  Note: A given 'SrcSpan' may appear in multiple AST elements,
+--  beware of duplicates
 getAnnotationComments :: ApiAnns -> SrcSpan -> [Located AnnotationComment]
 getAnnotationComments (_,anns) span =
   case Map.lookup span anns of
     Just cs -> cs
     Nothing -> []
 
+-- |Retrieve the comments allocated to the current 'SrcSpan', and
+-- remove them from the annotations
+getAndRemoveAnnotationComments :: ApiAnns -> SrcSpan
+                               -> ([Located AnnotationComment],ApiAnns)
+getAndRemoveAnnotationComments (anns,canns) span =
+  case Map.lookup span canns of
+    Just cs -> (cs,(anns,Map.delete span canns))
+    Nothing -> ([],(anns,canns))
+
 -- --------------------------------------------------------------------
 
--- | Note: in general the names of these are taken from the
+-- | API Annotations exist so that tools can perform source to source
+-- conversions of Haskell code. They are used to keep track of the
+-- various syntactic keywords that are not captured in the existing
+-- AST.
+--
+-- The annotations, together with original source comments are made
+-- available in the @'pm_annotations'@ field of @'GHC.ParsedModule'@.
+-- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set in
+-- @'DynFlags.DynFlags'@ before parsing.
+--
+-- The wiki page describing this feature is
+-- https://ghc.haskell.org/trac/ghc/wiki/ApiAnnotations
+--
+-- Note: in general the names of these are taken from the
 -- corresponding token, unless otherwise noted
 -- See note [Api annotations] above for details of the usage
 data AnnKeywordId
     = AnnAs
     | AnnAt
     | AnnBang  -- ^ '!'
+    | AnnBackquote -- ^ '`'
     | AnnBy
     | AnnCase -- ^ case or lambda case
     | AnnClass
-    | AnnClose -- ^  '}' or ']' or ')' or '#)' etc
+    | AnnClose -- ^  '\#)' or '\#-}'  etc
+    | AnnCloseC -- ^ '}'
+    | AnnCloseP -- ^ ')'
+    | AnnCloseS -- ^ ']'
     | AnnColon
-    | AnnComma
+    | AnnComma -- ^ as a list separator
+    | AnnCommaTuple -- ^ in a RdrName for a tuple
     | AnnDarrow -- ^ '=>'
     | AnnData
     | AnnDcolon -- ^ '::'
@@ -185,8 +228,14 @@ data AnnKeywordId
     | AnnMinus -- ^ '-'
     | AnnModule
     | AnnNewtype
+    | AnnName -- ^ where a name loses its location in the AST, this carries it
     | AnnOf
-    | AnnOpen   -- ^ '{' or '[' or '(' or '(#' etc
+    | AnnOpen   -- ^ '(\#' or '{-\# LANGUAGE' etc
+    | AnnOpenC   -- ^ '{'
+    | AnnOpenP   -- ^ '('
+    | AnnOpenPE   -- ^ '$('
+    | AnnOpenPTE   -- ^ '$$('
+    | AnnOpenS   -- ^ '['
     | AnnPackageName
     | AnnPattern
     | AnnProc
@@ -196,12 +245,19 @@ data AnnKeywordId
     | AnnRole
     | AnnSafe
     | AnnSemi -- ^ ';'
+    | AnnSimpleQuote -- ^ '''
+    | AnnStatic -- ^ 'static'
     | AnnThen
+    | AnnThIdSplice -- ^ '$'
+    | AnnThIdTySplice -- ^ '$$'
+    | AnnThTyQuote -- ^ double '''
     | AnnTilde -- ^ '~'
     | AnnTildehsh -- ^ '~#'
     | AnnType
+    | AnnUnit -- ^ '()' for types
     | AnnUsing
     | AnnVal  -- ^ e.g. INTEGER
+    | AnnValStr  -- ^ String value, will need quotes when output
     | AnnVbar -- ^ '|'
     | AnnWhere
     | Annlarrowtail -- ^ '-<'

compiler/parser/Lexer.x

@@ -56,7 +56,7 @@
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 
 module Lexer (
-   Token(..), SourceText, lexer, pragState, mkPState, PState(..),
+   Token(..), lexer, pragState, mkPState, PState(..),
    P(..), ParseResult(..), getSrcLoc,
    getPState, getDynFlags, withThisPackage,
    failLocMsgP, failSpanMsgP, srcParseFail,
@@ -73,7 +73,7 @@ module Lexer (
    sccProfilingOn, hpcEnabled,
    addWarning,
    lexTokenStream,
-   addAnnotation
+   addAnnotation,AddAnn,mkParensApiAnn
   ) where
 
 -- base
@@ -112,7 +112,8 @@ import DynFlags
 -- compiler/basicTypes
 import SrcLoc
 import Module
-import BasicTypes       ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )
+import BasicTypes     ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..),
+                        SourceText )
 
 -- compiler/parser
 import Ctype
@@ -155,7 +156,10 @@ $graphic   = [$small $large $symbol $digit $special $unigraphic \"\']
 $binit     = 0-1
 $octit     = 0-7
 $hexit     = [$decdigit A-F a-f]
-$idchar    = [$small $large $digit \']
+
+$suffix    = \x07 -- Trick Alex into handling Unicode. See alexGetByte.
+-- TODO #10196. Only allow modifier letters in the suffix of an identifier.
+$idchar    = [$small $large $digit $suffix \']
 
 $pragmachar = [$small $large $digit]
 
@@ -507,8 +511,6 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
 
 {
 
-type SourceText = String -- Note [literal source text] in HsLit
-
 -- -----------------------------------------------------------------------------
 -- The token type
 
@@ -560,34 +562,34 @@ data Token
   | ITpattern
   | ITstatic
 
-  -- Pragmas
-  | ITinline_prag InlineSpec RuleMatchInfo
-  | ITspec_prag                 -- SPECIALISE
-  | ITspec_inline_prag Bool     -- SPECIALISE INLINE (or NOINLINE)
-  | ITsource_prag
-  | ITrules_prag
-  | ITwarning_prag
-  | ITdeprecated_prag
+  -- Pragmas, see  note [Pragma source text] in BasicTypes
+  | ITinline_prag       SourceText InlineSpec RuleMatchInfo
+  | ITspec_prag         SourceText                -- SPECIALISE
+  | ITspec_inline_prag  SourceText Bool    -- SPECIALISE INLINE (or NOINLINE)
+  | ITsource_prag       SourceText
+  | ITrules_prag        SourceText
+  | ITwarning_prag      SourceText
+  | ITdeprecated_prag   SourceText
   | ITline_prag
-  | ITscc_prag
-  | ITgenerated_prag
-  | ITcore_prag                 -- hdaume: core annotations
-  | ITunpack_prag
-  | ITnounpack_prag
-  | ITann_prag
+  | ITscc_prag          SourceText
+  | ITgenerated_prag    SourceText
+  | ITcore_prag         SourceText         -- hdaume: core annotations
+  | ITunpack_prag       SourceText
+  | ITnounpack_prag     SourceText
+  | ITann_prag          SourceText
   | ITclose_prag
   | IToptions_prag String
   | ITinclude_prag String
   | ITlanguage_prag
-  | ITvect_prag
-  | ITvect_scalar_prag
-  | ITnovect_prag
-  | ITminimal_prag
-  | IToverlappable_prag         -- instance overlap mode
-  | IToverlapping_prag          -- instance overlap mode
-  | IToverlaps_prag             -- instance overlap mode
-  | ITincoherent_prag           -- instance overlap mode
-  | ITctype
+  | ITvect_prag         SourceText
+  | ITvect_scalar_prag  SourceText
+  | ITnovect_prag       SourceText
+  | ITminimal_prag      SourceText
+  | IToverlappable_prag SourceText  -- instance overlap mode
+  | IToverlapping_prag  SourceText  -- instance overlap mode
+  | IToverlaps_prag     SourceText  -- instance overlap mode
+  | ITincoherent_prag   SourceText  -- instance overlap mode
+  | ITctype             SourceText
 
   | ITdotdot                    -- reserved symbols
   | ITcolon
@@ -640,15 +642,15 @@ data Token
 
   | ITdupipvarid   FastString   -- GHC extension: implicit param: ?x
 
-  | ITchar       SourceText Char        -- Note [literal source text] in HsLit
-  | ITstring     SourceText FastString  -- Note [literal source text] in HsLit
-  | ITinteger    SourceText Integer     -- Note [literal source text] in HsLit
-  | ITrational   FractionalLit
+  | ITchar     SourceText Char       -- Note [Literal source text] in BasicTypes
+  | ITstring   SourceText FastString -- Note [Literal source text] in BasicTypes
+  | ITinteger  SourceText Integer    -- Note [Literal source text] in BasicTypes
+  | ITrational FractionalLit
 
-  | ITprimchar   SourceText Char        -- Note [literal source text] in HsLit
-  | ITprimstring SourceText ByteString  -- Note [literal source text] in HsLit
-  | ITprimint    SourceText Integer     -- Note [literal source text] in HsLit
-  | ITprimword   SourceText Integer     -- Note [literal source text] in HsLit
+  | ITprimchar   SourceText Char     -- Note [Literal source text] in BasicTypes
+  | ITprimstring SourceText ByteString -- Note [Literal source text] @BasicTypes
+  | ITprimint    SourceText Integer  -- Note [Literal source text] in BasicTypes
+  | ITprimword   SourceText Integer  -- Note [Literal source text] in BasicTypes
   | ITprimfloat  FractionalLit
   | ITprimdouble FractionalLit
 
@@ -702,6 +704,7 @@ data Token
 instance Outputable Token where
   ppr x = text (show x)
 
+
 -- the bitmap provided as the third component indicates whether the
 -- corresponding extension keyword is valid under the extension options
 -- provided to the compiler; if the extension corresponding to *any* of the
@@ -970,7 +973,7 @@ lineCommentToken span buf len = do
 nested_comment :: P (RealLocated Token) -> Action
 nested_comment cont span buf len = do
   input <- getInput
-  go (reverse $ drop 2 $ lexemeToString buf len) (1::Int) input
+  go (reverse $ lexemeToString buf len) (1::Int) input
   where
     go commentAcc 0 input = do
       setInput input
@@ -982,9 +985,9 @@ nested_comment cont span buf len = do
       Nothing -> errBrace input span
       Just ('-',input) -> case alexGetChar' input of
         Nothing  -> errBrace input span
-        Just ('\125',input) -> go commentAcc (n-1) input
+        Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}'
         Just (_,_)          -> go ('-':commentAcc) n input
-      Just ('\123',input) -> case alexGetChar' input of
+      Just ('\123',input) -> case alexGetChar' input of  -- '{' char
         Nothing  -> errBrace input span
         Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input
         Just (_,_)       -> go ('\123':commentAcc) n input
@@ -1029,9 +1032,10 @@ withLexedDocType lexDocComment = do
 -- RULES pragmas turn on the forall and '.' keywords, and we turn them
 -- off again at the end of the pragma.
 rulePrag :: Action
-rulePrag span _buf _len = do
+rulePrag span buf len = do
   setExts (.|. xbit InRulePragBit)
-  return (L span ITrules_prag)
+  let !src = lexemeToString buf len
+  return (L span (ITrules_prag src))
 
 endPrag :: Action
 endPrag span _buf _len = do
@@ -1834,6 +1838,7 @@ alexGetByte (AI loc s)
         symbol          = '\x04'
         space           = '\x05'
         other_graphic   = '\x06'
+        suffix          = '\x07'
 
         adj_c
           | c <= '\x06' = non_graphic
@@ -1850,7 +1855,7 @@ alexGetByte (AI loc s)
                   UppercaseLetter       -> upper
                   LowercaseLetter       -> lower
                   TitlecaseLetter       -> upper
-                  ModifierLetter        -> other_graphic
+                  ModifierLetter        -> suffix -- see #10196
                   OtherLetter           -> lower -- see #1103
                   NonSpacingMark        -> other_graphic
                   SpacingCombiningMark  -> other_graphic
@@ -2518,36 +2523,38 @@ ignoredPrags = Map.fromList (map ignored pragmas)
                      -- CFILES is a hugs-only thing.
                      pragmas = options_pragmas ++ ["cfiles", "contract"]
 
-oneWordPrags = Map.fromList([("rules", rulePrag),
-                           ("inline", token (ITinline_prag Inline FunLike)),
-                           ("inlinable", token (ITinline_prag Inlinable FunLike)),
-                           ("inlineable", token (ITinline_prag Inlinable FunLike)),
+oneWordPrags = Map.fromList([
+           ("rules", rulePrag),
+           ("inline", strtoken (\s -> (ITinline_prag s Inline FunLike))),
+           ("inlinable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))),
+           ("inlineable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))),
                                           -- Spelling variant
-                           ("notinline", token (ITinline_prag NoInline FunLike)),
-                           ("specialize", token ITspec_prag),
-                           ("source", token ITsource_prag),
-                           ("warning", token ITwarning_prag),
-                           ("deprecated", token ITdeprecated_prag),
-                           ("scc", token ITscc_prag),
-                           ("generated", token ITgenerated_prag),
-                           ("core", token ITcore_prag),
-                           ("unpack", token ITunpack_prag),
-                           ("nounpack", token ITnounpack_prag),
-                           ("ann", token ITann_prag),
-                           ("vectorize", token ITvect_prag),
-                           ("novectorize", token ITnovect_prag),
-                           ("minimal", token ITminimal_prag),
-                           ("overlaps", token IToverlaps_prag),
-                           ("overlappable", token IToverlappable_prag),
-                           ("overlapping", token IToverlapping_prag),
-                           ("incoherent", token ITincoherent_prag),
-                           ("ctype", token ITctype)])
-
-twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
-                             ("notinline conlike", token (ITinline_prag NoInline ConLike)),
-                             ("specialize inline", token (ITspec_inline_prag True)),
-                             ("specialize notinline", token (ITspec_inline_prag False)),
-                             ("vectorize scalar", token ITvect_scalar_prag)])
+           ("notinline", strtoken (\s -> (ITinline_prag s NoInline FunLike))),
+           ("specialize", strtoken (\s -> ITspec_prag s)),
+           ("source", strtoken (\s -> ITsource_prag s)),
+           ("warning", strtoken (\s -> ITwarning_prag s)),
+           ("deprecated", strtoken (\s -> ITdeprecated_prag s)),
+           ("scc", strtoken (\s -> ITscc_prag s)),
+           ("generated", strtoken (\s -> ITgenerated_prag s)),
+           ("core", strtoken (\s -> ITcore_prag s)),
+           ("unpack", strtoken (\s -> ITunpack_prag s)),
+           ("nounpack", strtoken (\s -> ITnounpack_prag s)),
+           ("ann", strtoken (\s -> ITann_prag s)),
+           ("vectorize", strtoken (\s -> ITvect_prag s)),
+           ("novectorize", strtoken (\s -> ITnovect_prag s)),
+           ("minimal", strtoken (\s -> ITminimal_prag s)),
+           ("overlaps", strtoken (\s -> IToverlaps_prag s)),
+           ("overlappable", strtoken (\s -> IToverlappable_prag s)),
+           ("overlapping", strtoken (\s -> IToverlapping_prag s)),
+           ("incoherent", strtoken (\s -> ITincoherent_prag s)),
+           ("ctype", strtoken (\s -> ITctype s))])
+
+twoWordPrags = Map.fromList([
+     ("inline conlike", strtoken (\s -> (ITinline_prag s Inline ConLike))),
+     ("notinline conlike", strtoken (\s -> (ITinline_prag s NoInline ConLike))),
+     ("specialize inline", strtoken (\s -> (ITspec_inline_prag s True))),
+     ("specialize notinline", strtoken (\s -> (ITspec_inline_prag s False))),
+     ("vectorize scalar", strtoken (\s -> ITvect_scalar_prag s))])
 
 dispatch_pragmas :: Map String Action -> Action
 dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
@@ -2585,6 +2592,10 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
 %************************************************************************
 -}
 
+-- |Encapsulated call to addAnnotation, requiring only the SrcSpan of
+-- the AST element the annotation belongs to
+type AddAnn = (SrcSpan -> P ())
+
 addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P ()
 addAnnotation l a v = do
   addAnnotationOnly l a v
@@ -2595,6 +2606,22 @@ addAnnotationOnly l a v = P $ \s -> POk s {
   annotations = ((l,a), [v]) : annotations s
   } ()
 
+-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
+-- 'AddAnn' values for the opening and closing bordering on the start
+-- and end of the span
+mkParensApiAnn :: SrcSpan -> [AddAnn]
+mkParensApiAnn (UnhelpfulSpan _)  = []
+mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc]
+  where
+    mj a l = (\s -> addAnnotation s a l)
+    f = srcSpanFile ss
+    sl = srcSpanStartLine ss
+    sc = srcSpanStartCol ss
+    el = srcSpanEndLine ss
+    ec = srcSpanEndCol ss
+    lo = mkSrcSpan (srcSpanStart s)         (mkSrcLoc f sl (sc+1))
+    lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s)
+
 queueComment :: Located Token -> P()
 queueComment c = P $ \s -> POk s {
   comment_q = commentToAnnotation c : comment_q s

compiler/parser/RdrHsSyn.hs

@@ -72,7 +72,8 @@ import RdrName          ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
 import OccName          ( tcClsName, isVarNameSpace )
 import Name             ( Name )
 import BasicTypes       ( maxPrecedence, Activation(..), RuleMatchInfo,
-                          InlinePragma(..), InlineSpec(..), Origin(..) )
+                          InlinePragma(..), InlineSpec(..), Origin(..),
+                          SourceText )
 import TcEvidence       ( idHsWrapper )
 import Lexer
 import TysWiredIn       ( unitTyCon, unitDataCon )
@@ -88,8 +89,11 @@ import Outputable
 import FastString
 import Maybes
 import Util
+import ApiAnnotation
 
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative ((<$>))
+#endif
 import Control.Monad
 
 import Text.ParserCombinators.ReadP as ReadP
@@ -126,20 +130,22 @@ mkInstD (L loc d) = L loc (InstD d)
 
 mkClassDecl :: SrcSpan
             -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-            -> Located [Located (FunDep RdrName)]
+            -> Located (a,[Located (FunDep (Located RdrName))])
             -> OrdList (LHsDecl RdrName)
             -> P (LTyClDecl RdrName)
 
 mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
   = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls
        ; let cxt = fromMaybe (noLoc []) mcxt
-       ; (cls, tparams) <- checkTyClHdr tycl_hdr
+       ; (cls, tparams,ann) <- checkTyClHdr tycl_hdr
+       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        -- Partial type signatures are not allowed in a class definition
        ; checkNoPartialSigs sigs cls
        ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams
        ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
        ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
-                                    tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
+                                    tcdFDs = snd (unLoc fds), tcdSigs = sigs,
+                                    tcdMeths = binds,
                                     tcdATs = ats, tcdATDefs = at_defs, tcdDocs  = docs,
                                     tcdFVs = placeHolderNames })) }
 
@@ -188,7 +194,7 @@ checkNoPartialCon con_decls =
                            (hsConDeclArgTys details) ]
   where err con_decl = text "A constructor cannot have a partial type:" $$
                        ppr con_decl
-        containsWildcardRes (ResTyGADT ty) = findWildcards ty
+        containsWildcardRes (ResTyGADT _ ty) = findWildcards ty
         containsWildcardRes ResTyH98 = notFound
 
 -- | Check that the given type does not contain wildcards, and is thus not a
@@ -265,7 +271,8 @@ mkTyData :: SrcSpan
          -> Maybe (Located [LHsType RdrName])
          -> P (LTyClDecl RdrName)
 mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
-  = do { (tc, tparams) <- checkTyClHdr tycl_hdr
+  = do { (tc, tparams,ann) <- checkTyClHdr tycl_hdr
+       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
        ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
@@ -299,7 +306,8 @@ mkTySynonym :: SrcSpan
             -> LHsType RdrName  -- RHS
             -> P (LTyClDecl RdrName)
 mkTySynonym loc lhs rhs
-  = do { (tc, tparams) <- checkTyClHdr lhs
+  = do { (tc, tparams,ann) <- checkTyClHdr lhs
+       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (ptext (sLit "type")) equalsDots tc tparams
        ; let err = text "In type synonym" <+> quotes (ppr tc) <>
                    colon <+> ppr rhs
@@ -309,9 +317,9 @@ mkTySynonym loc lhs rhs
 
 mkTyFamInstEqn :: LHsType RdrName
                -> LHsType RdrName
-               -> P (TyFamInstEqn RdrName)
+               -> P (TyFamInstEqn RdrName,[AddAnn])
 mkTyFamInstEqn lhs rhs
-  = do { (tc, tparams) <- checkTyClHdr lhs
+  = do { (tc, tparams,ann) <- checkTyClHdr lhs
        ; let err xhs = hang (text "In type family instance equation of" <+>
                              quotes (ppr tc) <> colon)
                        2 (ppr xhs)
@@ -319,7 +327,8 @@ mkTyFamInstEqn lhs rhs
        ; checkNoPartialType (err rhs) rhs
        ; return (TyFamEqn { tfe_tycon = tc
                           , tfe_pats  = mkHsWithBndrs tparams
-                          , tfe_rhs   = rhs }) }
+                          , tfe_rhs   = rhs },
+                 ann) }
 
 mkDataFamInst :: SrcSpan
          -> NewOrData
@@ -330,7 +339,8 @@ mkDataFamInst :: SrcSpan
          -> Maybe (Located [LHsType RdrName])
          -> P (LInstDecl RdrName)
 mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
-  = do { (tc, tparams) <- checkTyClHdr tycl_hdr
+  = do { (tc, tparams,ann) <- checkTyClHdr tycl_hdr
+       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
        ; return (L loc (DataFamInstD (
                   DataFamInstDecl { dfid_tycon = tc, dfid_pats = mkHsWithBndrs tparams
@@ -349,7 +359,8 @@ mkFamDecl :: SrcSpan
           -> Maybe (LHsKind RdrName) -- Optional kind signature
           -> P (LTyClDecl RdrName)
 mkFamDecl loc info lhs ksig
-  = do { (tc, tparams) <- checkTyClHdr lhs
+  = do { (tc, tparams,ann) <- checkTyClHdr lhs
+       ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
        ; return (L loc (FamDecl (FamilyDecl { fdInfo = info, fdLName = tc
                                             , fdTyVars = tyvars, fdKindSig = ksig }))) }
@@ -504,7 +515,7 @@ getMonoBind bind binds = (bind, binds)
 
 has_args :: [LMatch RdrName (LHsExpr RdrName)] -> Bool
 has_args []                           = panic "RdrHsSyn:has_args"
-has_args ((L _ (Match args _ _)) : _) = not (null args)
+has_args ((L _ (Match _ args _ _)) : _) = not (null args)
         -- Don't group together FunBinds if they have
         -- no arguments.  This is necessary now that variable bindings
         -- with no arguments are now treated as FunBinds rather
@@ -540,7 +551,7 @@ splitCon ty
                                          -- See Note [Unit tuples] in HsTypes
    split (L l _) _                 = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
 
-   mk_rest [L _ (HsRecTy flds)] = RecCon flds
+   mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)
    mk_rest ts                   = PrefixCon ts
 
 recordPatSynErr :: SrcSpan -> LPat RdrName -> P a
@@ -560,8 +571,9 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
         do { unless (name == patsyn_name) $
                wrongNameBindingErr loc decl
            ; match <- case details of
-               PrefixCon pats -> return $ Match pats Nothing rhs
-               InfixCon pat1 pat2 -> return $ Match [pat1, pat2] Nothing rhs
+               PrefixCon pats -> return $ Match Nothing pats Nothing rhs
+               InfixCon pat1 pat2 ->
+                         return $ Match Nothing [pat1, pat2] Nothing rhs
                RecCon{} -> recordPatSynErr loc pat
            ; return $ L loc match }
     fromDecl (L loc decl) = extraDeclErr loc decl
@@ -578,7 +590,7 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
 
 mkDeprecatedGadtRecordDecl :: SrcSpan
                            -> Located RdrName
-                           -> [LConDeclField RdrName]
+                           -> Located [LConDeclField RdrName]
                            -> LHsType RdrName
                            ->  P (LConDecl  RdrName)
 -- This one uses the deprecated syntax
@@ -592,7 +604,7 @@ mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
                                 , con_qvars    = mkHsQTvs []
                                 , con_cxt      = noLoc []
                                 , con_details  = RecCon flds
-                                , con_res      = ResTyGADT res_ty
+                                , con_res      = ResTyGADT loc res_ty
                                 , con_doc      = Nothing })) }
 
 mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
@@ -610,22 +622,33 @@ mkSimpleConDecl name qvars cxt details
             , con_doc      = Nothing }
 
 mkGadtDecl :: [Located RdrName]
+           -> LHsType RdrName     -- Always a HsForAllTy
+           -> P ([AddAnn], ConDecl RdrName)
+mkGadtDecl names (L l ty) = do
+  let
+    (anns,ty') = flattenHsForAllTyKeepAnns ty
+  gadt <- mkGadtDecl' names (L l ty')
+  return (anns,gadt)
+
+mkGadtDecl' :: [Located RdrName]
            -> LHsType RdrName     -- Always a HsForAllTy
            -> P (ConDecl RdrName)
+
 -- We allow C,D :: ty
 -- and expand it as if it had been
 --    C :: ty; D :: ty
 -- (Just like type signatures in general.)
-mkGadtDecl _ ty@(L _ (HsForAllTy _ (Just l) _ _ _))
+mkGadtDecl' _ ty@(L _ (HsForAllTy _ (Just l) _ _ _))
   = parseErrorSDoc l $
     text "A constructor cannot have a partial type:" $$
     ppr ty
-mkGadtDecl names (L _ (HsForAllTy imp Nothing qvars cxt tau))
+mkGadtDecl' names (L ls (HsForAllTy imp Nothing qvars cxt tau))
   = return $ mk_gadt_con names
   where
     (details, res_ty)           -- See Note [Sorting out the result type]
       = case tau of
-          L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds,  res_ty)
+          L _ (HsFunTy (L l (HsRecTy flds)) res_ty)
+                                            -> (RecCon (L l flds), res_ty)
           _other                                    -> (PrefixCon [], tau)
 
     mk_gadt_con names
@@ -635,9 +658,9 @@ mkGadtDecl names (L _ (HsForAllTy imp Nothing qvars cxt tau))
                  , con_qvars    = qvars
                  , con_cxt      = cxt
                  , con_details  = details
-                 , con_res      = ResTyGADT res_ty
+                 , con_res      = ResTyGADT ls res_ty
                  , con_doc      = Nothing }
-mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
+mkGadtDecl' _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
 
 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 tyConToDataCon loc tc
@@ -689,8 +712,8 @@ checkTyVars pp_what equals_or_where tc tparms
   where
 
         -- Check that the name space is correct!
-    chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
-        | isRdrTyVar tv    = return (L l (KindedTyVar tv k))
+    chk (L l (HsKindSig (L lv (HsTyVar tv)) k))
+        | isRdrTyVar tv    = return (L l (KindedTyVar (L lv tv) k))
     chk (L l (HsTyVar tv))
         | isRdrTyVar tv    = return (L l (UserTyVar tv))
     chk t@(L loc _)
@@ -729,38 +752,43 @@ checkRecordSyntax lr@(L loc r)
 
 checkTyClHdr :: LHsType RdrName
              -> P (Located RdrName,          -- the head symbol (type or class name)
-                   [LHsType RdrName])        -- parameters of head symbol
+                   [LHsType RdrName],        -- parameters of head symbol
+                   [AddAnn]) -- API Annotation for HsParTy when stripping parens
 -- Well-formedness check and decomposition of type and class heads.
 -- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
 --              Int :*: Bool   into    (:*:, [Int, Bool])
 -- returning the pieces
 checkTyClHdr ty
-  = goL ty []
+  = goL ty [] []
   where
-    goL (L l ty) acc = go l ty acc
-
-    go l (HsTyVar tc) acc
-        | isRdrTc tc          = return (L l tc, acc)
-    go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc
-        | isRdrTc tc         = return (ltc, t1:t2:acc)
-    go _ (HsParTy ty)    acc = goL ty acc
-    go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
-    go l (HsTupleTy _ []) [] = return (L l (getRdrName unitTyCon), [])
+    goL (L l ty) acc ann = go l ty acc ann
+
+    go l (HsTyVar tc) acc ann
+        | isRdrTc tc             = return (L l tc, acc, ann)
+    go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc ann
+        | isRdrTc tc             = return (ltc, t1:t2:acc, ann)
+    go l (HsParTy ty)    acc ann = goL ty acc (ann ++ mkParensApiAnn l)
+    go _ (HsAppTy t1 t2) acc ann = goL t1 (t2:acc) ann
+    go l (HsTupleTy _ []) [] ann = return (L l (getRdrName unitTyCon), [],ann)
                                    -- See Note [Unit tuples] in HsTypes
-    go l _               _   = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty)
+    go l _               _   _
+         = parseErrorSDoc l (text "Malformed head of type or class declaration:"
+                             <+> ppr ty)
 
-checkContext :: LHsType RdrName -> P (LHsContext RdrName)
+checkContext :: LHsType RdrName -> P ([AddAnn],LHsContext RdrName)
 checkContext (L l orig_t)
-  = check orig_t
+  = check [] (L l orig_t)
  where
-  check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
-    = return (L l ts)           -- Ditto ()
+  check anns (L lp (HsTupleTy _ ts))   -- (Eq a, Ord b) shows up as a tuple type
+    = return (anns ++ mkParensApiAnn lp,L l ts)                -- Ditto ()
 
-  check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
-    = check (unLoc ty)
+  check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way
+       = check anns' ty
+         where anns' = if l == lp1 then anns
+                                   else (anns ++ mkParensApiAnn lp1)
 
-  check _
-    = return (L l [L l orig_t])
+  check _anns _
+    = return ([],L l [L l orig_t]) -- no need for anns, returning original
 
 -- -------------------------------------------------------------------------
 -- Checking Patterns.
@@ -808,14 +836,16 @@ checkAPat msg loc e0 = do
    -- Overloaded numeric patterns (e.g. f 0 x = x)
    -- Negation is recorded separately, so that the literal is zero or +ve
    -- NB. Negative *primitive* literals are already handled by the lexer
-   HsOverLit pos_lit          -> return (mkNPat pos_lit Nothing)
-   NegApp (L _ (HsOverLit pos_lit)) _
-                        -> return (mkNPat pos_lit (Just noSyntaxExpr))
+   HsOverLit pos_lit          -> return (mkNPat (L loc pos_lit) Nothing)
+   NegApp (L l (HsOverLit pos_lit)) _
+                        -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
 
-   SectionR (L _ (HsVar bang)) e        -- (! x)
+   SectionR (L lb (HsVar bang)) e        -- (! x)
         | bang == bang_RDR
         -> do { bang_on <- extension bangPatEnabled
-              ; if bang_on then checkLPat msg e >>= (return . BangPat)
+              ; if bang_on then do { e' <- checkLPat msg e
+                                   ; addAnnotation loc AnnBang lb
+                                   ; return  (BangPat e') }
                 else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) }
 
    ELazyPat e         -> checkLPat msg e >>= (return . LazyPat)
@@ -835,9 +865,9 @@ checkAPat msg loc e0 = do
 
    -- n+k patterns
    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
-         (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
+         (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
                       | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
-                      -> return (mkNPlusKPat (L nloc n) lit)
+                      -> return (mkNPlusKPat (L nloc n) (L lloc lit))
 
    OpApp l op _fix r  -> do l <- checkLPat msg l
                             r <- checkLPat msg r
@@ -894,7 +924,7 @@ checkValDef :: SDoc
             -> LHsExpr RdrName
             -> Maybe (LHsType RdrName)
             -> Located (a,GRHSs RdrName (LHsExpr RdrName))
-            -> P (HsBind RdrName)
+            -> P ([AddAnn],HsBind RdrName)
 
 checkValDef msg lhs (Just sig) grhss
         -- x :: ty = rhs  parses as a *pattern* binding
@@ -904,22 +934,27 @@ checkValDef msg lhs (Just sig) grhss
 checkValDef msg lhs opt_sig g@(L l (_,grhss))
   = do  { mb_fun <- isFunLhs lhs
         ; case mb_fun of
-            Just (fun, is_infix, pats) -> checkFunBind msg (getLoc lhs)
+            Just (fun, is_infix, pats, ann) ->
+              checkFunBind msg ann (getLoc lhs)
                                            fun is_infix pats opt_sig (L l grhss)
             Nothing -> checkPatBind msg lhs g }
 
 checkFunBind :: SDoc
+             -> [AddAnn]
              -> SrcSpan
              -> Located RdrName
              -> Bool
              -> [LHsExpr RdrName]
              -> Maybe (LHsType RdrName)
              -> Located (GRHSs RdrName (LHsExpr RdrName))
-             -> P (HsBind RdrName)
-checkFunBind msg lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
+             -> P ([AddAnn],HsBind RdrName)
+checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
   = do  ps <- checkPatterns msg pats
         let match_span = combineSrcSpans lhs_loc rhs_span
-        return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
+        -- Add back the annotations stripped from any HsPar values in the lhs
+        -- mapM_ (\a -> a match_span) ann
+        return (ann,makeFunBind fun is_infix
+                  [L match_span (Match (Just (fun,is_infix)) ps opt_sig grhss)])
         -- The span of the match covers the entire equation.
         -- That isn't quite right, but it'll do for now.
 
@@ -936,10 +971,10 @@ makeFunBind fn is_infix ms
 checkPatBind :: SDoc
              -> LHsExpr RdrName
              -> Located (a,GRHSs RdrName (LHsExpr RdrName))
-             -> P (HsBind RdrName)
+             -> P ([AddAnn],HsBind RdrName)
 checkPatBind msg lhs (L _ (_,grhss))
   = do  { lhs <- checkPattern msg lhs
-        ; return (PatBind lhs grhss placeHolderType placeHolderNames
+        ; return ([],PatBind lhs grhss placeHolderType placeHolderNames
                     ([],[])) }
 
 checkValSig
@@ -1134,16 +1169,17 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
         -- not be any OpApps inside the e's
 splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
 -- Splits (f ! g a b) into (f, [(! g), a, b])
-splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
-  | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
+splitBang (L _ (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
+  | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns)
   where
+    l' = combineLocs bang arg1
     (arg1,argns) = split_bang r_arg []
     split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
     split_bang e                 es = (e,es)
 splitBang _ = Nothing
 
 isFunLhs :: LHsExpr RdrName
-         -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
+         -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName],[AddAnn]))
 -- A variable binding is parsed as a FunBind.
 -- Just (fun, is_infix, arg_pats) if e is a function LHS
 --
@@ -1156,12 +1192,12 @@ isFunLhs :: LHsExpr RdrName
 --
 -- a .!. !b
 
-isFunLhs e = go e []
+isFunLhs e = go e [] []
  where
-   go (L loc (HsVar f)) es
-        | not (isRdrDataCon f)   = return (Just (L loc f, False, es))
-   go (L _ (HsApp f e)) es       = go f (e:es)
-   go (L _ (HsPar e))   es@(_:_) = go e es
+   go (L loc (HsVar f)) es ann
+        | not (isRdrDataCon f)       = return (Just (L loc f, False, es, ann))
+   go (L _ (HsApp f e)) es       ann = go f (e:es) ann
+   go (L l (HsPar e))   es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
 
         -- For infix function defns, there should be only one infix *function*
         -- (though there may be infix *datacons* involved too).  So we don't
@@ -1176,23 +1212,23 @@ isFunLhs e = go e []
         -- ToDo: what about this?
         --              x + 1 `op` y = ...
 
-   go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
+   go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es ann
         | Just (e',es') <- splitBang e
         = do { bang_on <- extension bangPatEnabled
-             ; if bang_on then go e' (es' ++ es)
-               else return (Just (L loc' op, True, (l:r:es))) }
+             ; if bang_on then go e' (es' ++ es) ann
+               else return (Just (L loc' op, True, (l:r:es), ann)) }
                 -- No bangs; behave just like the next case
         | not (isRdrDataCon op)         -- We have found the function!
-        = return (Just (L loc' op, True, (l:r:es)))
+        = return (Just (L loc' op, True, (l:r:es), ann))
         | otherwise                     -- Infix data con; keep going
-        = do { mb_l <- go l es
+        = do { mb_l <- go l es ann
              ; case mb_l of
-                 Just (op', True, j : k : es')
-                    -> return (Just (op', True, j : op_app : es'))
+                 Just (op', True, j : k : es', ann')
+                    -> return (Just (op', True, j : op_app : es', ann'))
                     where
                       op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
                  _ -> return Nothing }
-   go _ _ = return Nothing
+   go _ _ _ = return Nothing
 
 
 ---------------------------------------------------------------------------
@@ -1272,9 +1308,9 @@ checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrN
 checkCmdMatchGroup mg@(MG { mg_alts = ms }) = do
     ms' <- mapM (locMap $ const convert) ms
     return $ mg { mg_alts = ms' }
-    where convert (Match pat mty grhss) = do
+    where convert (Match mf pat mty grhss) = do
             grhss' <- checkCmdGRHSs grhss
-            return $ Match pat mty grhss'
+            return $ Match mf pat mty grhss'
 
 checkCmdGRHSs :: GRHSs RdrName (LHsExpr RdrName) -> P (GRHSs RdrName (LHsCmd RdrName))
 checkCmdGRHSs (GRHSs grhss binds) = do
@@ -1321,11 +1357,13 @@ mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 
-mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
+mkInlinePragma :: String -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
+               -> InlinePragma
 -- The (Maybe Activation) is because the user can omit
 -- the activation spec (and usually does)
-mkInlinePragma (inl, match_info) mb_act
-  = InlinePragma { inl_inline = inl
+mkInlinePragma src (inl, match_info) mb_act
+  = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes
+                 , inl_inline = inl
                  , inl_sat    = Nothing
                  , inl_act    = act
                  , inl_rule   = match_info }
@@ -1355,16 +1393,16 @@ mkImport (L lc cconv) (L ls safety) (L loc entity, v, ty)
   | cconv == PrimCallConv                      = do
   let funcTarget = CFunction (StaticTarget entity Nothing True)
       importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget
-                           (L loc entity)
+                           (L loc (unpackFS entity))
   return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
   | cconv == JavaScriptCallConv = do
   let funcTarget = CFunction (StaticTarget entity Nothing True)
       importSpec = CImport (L lc JavaScriptCallConv) (L ls safety) Nothing
-                           funcTarget (L loc entity)
+                           funcTarget (L loc (unpackFS entity))
   return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
   | otherwise = do
     case parseCImport (L lc cconv) (L ls safety) (mkExtName (unLoc v))
-                      (unpackFS entity) (L loc entity) of
+                      (unpackFS entity) (L loc (unpackFS entity)) of
       Nothing         -> parseErrorSDoc loc (text "Malformed entity string")
       Just importSpec -> return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
 
@@ -1372,7 +1410,7 @@ mkImport (L lc cconv) (L ls safety) (L loc entity, v, ty)
 -- C identifier case comes first in the alternatives below, so we pick
 -- that one.
 parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
-             -> Located FastString
+             -> Located SourceText
              -> Maybe ForeignImport
 parseCImport cconv safety nm str sourceText =
  listToMaybe $ map fst $ filter (null.snd) $
@@ -1433,7 +1471,8 @@ mkExport (L lc cconv) (L le entity, v, ty) = do
   checkNoPartialType (ptext (sLit "In foreign export declaration") <+>
                       quotes (ppr v) $$ ppr ty) ty
   return $ ForD (ForeignExport v ty noForeignExportCoercionYet
-                 (CExport (L lc (CExportStatic entity' cconv)) (L le entity)))
+                 (CExport (L lc (CExportStatic entity' cconv))
+                          (L le (unpackFS entity))))
   where
     entity' | nullFS entity = mkExtName (unLoc v)
             | otherwise     = entity
@@ -1457,7 +1496,7 @@ mkModuleImpExp n@(L l name) subs =
   case subs of
     ImpExpAbs
       | isVarNameSpace (rdrNameSpace name) -> IEVar       n
-      | otherwise                          -> IEThingAbs  nameT
+      | otherwise                          -> IEThingAbs  (L l nameT)
     ImpExpAll                              -> IEThingAll  (L l nameT)
     ImpExpList xs                          -> IEThingWith (L l nameT) xs
 

compiler/prelude/ForeignCall.hs

@@ -22,6 +22,7 @@ import FastString
 import Binary
 import Outputable
 import Module
+import BasicTypes ( SourceText )
 
 import Data.Char
 import Data.Data
@@ -228,12 +229,19 @@ instance Outputable Header where
     ppr (Header h) = quotes $ ppr h
 
 -- | A C type, used in CAPI FFI calls
-data CType = CType (Maybe Header) -- header to include for this type
+--
+--  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@,
+--        'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal',
+--        'ApiAnnotation.AnnClose' @'\#-}'@,
+
+-- For details on above see note [Api annotations] in ApiAnnotation
+data CType = CType SourceText -- Note [Pragma source text] in BasicTypes
+                   (Maybe Header) -- header to include for this type
                    FastString     -- the type itself
     deriving (Data, Typeable)
 
 instance Outputable CType where
-    ppr (CType mh ct) = hDoc <+> ftext ct
+    ppr (CType _ mh ct) = hDoc <+> ftext ct
         where hDoc = case mh of
                      Nothing -> empty
                      Just h -> ppr h
@@ -323,11 +331,13 @@ instance Binary CCallConv where
               _ -> do return JavaScriptCallConv
 
 instance Binary CType where
-    put_ bh (CType mh fs) = do put_ bh mh
-                               put_ bh fs
-    get bh = do mh <- get bh
+    put_ bh (CType s mh fs) = do put_ bh s
+                                 put_ bh mh
+                                 put_ bh fs
+    get bh = do s  <- get bh
+                mh <- get bh
                 fs <- get bh
-                return (CType mh fs)
+                return (CType s mh fs)
 
 instance Binary Header where
     put_ bh (Header h) = put_ bh h

compiler/prelude/PrelNames.hs

@@ -213,7 +213,15 @@ basicKnownKeyNames
         alternativeClassName,
         foldableClassName,
         traversableClassName,
-        typeableClassName,              -- derivable
+
+        -- Typeable
+        typeableClassName,
+        typeRepTyConName,
+        mkTyConName,
+        mkPolyTyConAppName,
+        mkAppTyName,
+        typeLitTypeRepName,
+
 
         -- Numeric stuff
         negateName, minusName, geName, eqName,
@@ -323,6 +331,10 @@ basicKnownKeyNames
         -- Implicit parameters
         ipClassName,
 
+        -- Source locations
+        callStackDataConName, callStackTyConName,
+        srcLocDataConName,
+
         -- Annotation type checking
         toAnnotationWrapperName
 
@@ -455,6 +467,12 @@ gHC_IP          = mkBaseModule (fsLit "GHC.IP")
 gHC_PARR' :: Module
 gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
 
+gHC_SRCLOC :: Module
+gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc")
+
+gHC_STACK :: Module
+gHC_STACK = mkBaseModule (fsLit "GHC.Stack")
+
 gHC_STATICPTR :: Module
 gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")
 
@@ -1020,9 +1038,21 @@ rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDo
 ixClassName :: Name
 ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey
 
--- Class Typeable
-typeableClassName :: Name
-typeableClassName     = clsQual tYPEABLE_INTERNAL    (fsLit "Typeable")  typeableClassKey
+-- Class Typeable, and functions for constructing `Typeable` dictionaries
+typeableClassName
+  , typeRepTyConName
+  , mkTyConName
+  , mkPolyTyConAppName
+  , mkAppTyName
+  , typeLitTypeRepName
+  :: Name
+typeableClassName     = clsQual tYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey
+typeRepTyConName      = tcQual  tYPEABLE_INTERNAL (fsLit "TypeRep")        typeRepTyConKey
+mkTyConName           = varQual tYPEABLE_INTERNAL (fsLit "mkTyCon")        mkTyConKey
+mkPolyTyConAppName    = varQual tYPEABLE_INTERNAL (fsLit "mkPolyTyConApp") mkPolyTyConAppKey
+mkAppTyName           = varQual tYPEABLE_INTERNAL (fsLit "mkAppTy")        mkAppTyKey
+typeLitTypeRepName    = varQual tYPEABLE_INTERNAL (fsLit "typeLitTypeRep") typeLitTypeRepKey
+
 
 
 -- Class Data
@@ -1167,6 +1197,15 @@ knownSymbolClassName  = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolCl
 ipClassName :: Name
 ipClassName         = clsQual gHC_IP (fsLit "IP")      ipClassNameKey
 
+-- Source Locations
+callStackDataConName, callStackTyConName, srcLocDataConName :: Name
+callStackDataConName
+  = conName gHC_STACK (fsLit "CallStack") callStackDataConKey
+callStackTyConName
+  = tcQual  gHC_STACK (fsLit "CallStack") callStackTyConKey
+srcLocDataConName
+  = conName gHC_SRCLOC (fsLit "SrcLoc")   srcLocDataConKey
+
 -- plugins
 pLUGINS :: Module
 pLUGINS = mkThisGhcModule (fsLit "Plugins")
@@ -1517,6 +1556,12 @@ staticPtrTyConKey  = mkPreludeTyConUnique 180
 staticPtrInfoTyConKey :: Unique
 staticPtrInfoTyConKey = mkPreludeTyConUnique 181
 
+typeRepTyConKey :: Unique
+typeRepTyConKey = mkPreludeTyConUnique 183
+
+callStackTyConKey :: Unique
+callStackTyConKey = mkPreludeTyConUnique 182
+
 ---------------- Template Haskell -------------------
 --      USES TyConUniques 200-299
 -----------------------------------------------------
@@ -1589,6 +1634,10 @@ staticPtrInfoDataConKey                 = mkPreludeDataConUnique 34
 fingerprintDataConKey :: Unique
 fingerprintDataConKey                   = mkPreludeDataConUnique 35
 
+callStackDataConKey, srcLocDataConKey :: Unique
+callStackDataConKey                     = mkPreludeDataConUnique 36
+srcLocDataConKey                        = mkPreludeDataConUnique 37
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1844,6 +1893,18 @@ proxyHashKey = mkPreludeMiscIdUnique 502
 --      USES IdUniques 200-499
 -----------------------------------------------------
 
+-- Used to make `Typeable` dictionaries
+mkTyConKey
+  , mkPolyTyConAppKey
+  , mkAppTyKey
+  , typeLitTypeRepKey
+  :: Unique
+mkTyConKey        = mkPreludeMiscIdUnique 503
+mkPolyTyConAppKey = mkPreludeMiscIdUnique 504
+mkAppTyKey        = mkPreludeMiscIdUnique 505
+typeLitTypeRepKey = mkPreludeMiscIdUnique 506
+
+
 {-
 ************************************************************************
 *                                                                      *

compiler/prelude/PrelRules.hs

@@ -241,19 +241,19 @@ primOpRules nm CharGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]
 primOpRules nm CharLeOp   = mkRelOpRule nm (<=) [ boundsCmp Le ]
 primOpRules nm CharLtOp   = mkRelOpRule nm (<)  [ boundsCmp Lt ]
 
-primOpRules nm FloatGtOp  = mkFloatingRelOpRule nm (>)  []
-primOpRules nm FloatGeOp  = mkFloatingRelOpRule nm (>=) []
-primOpRules nm FloatLeOp  = mkFloatingRelOpRule nm (<=) []
-primOpRules nm FloatLtOp  = mkFloatingRelOpRule nm (<)  []
-primOpRules nm FloatEqOp  = mkFloatingRelOpRule nm (==) [ litEq True ]
-primOpRules nm FloatNeOp  = mkFloatingRelOpRule nm (/=) [ litEq False ]
-
-primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>)  []
-primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=) []
-primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=) []
-primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<)  []
-primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==) [ litEq True ]
-primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) [ litEq False ]
+primOpRules nm FloatGtOp  = mkFloatingRelOpRule nm (>)
+primOpRules nm FloatGeOp  = mkFloatingRelOpRule nm (>=)
+primOpRules nm FloatLeOp  = mkFloatingRelOpRule nm (<=)
+primOpRules nm FloatLtOp  = mkFloatingRelOpRule nm (<)
+primOpRules nm FloatEqOp  = mkFloatingRelOpRule nm (==)
+primOpRules nm FloatNeOp  = mkFloatingRelOpRule nm (/=)
+
+primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>)
+primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=)
+primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=)
+primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<)
+primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==)
+primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=)
 
 primOpRules nm WordGtOp   = mkRelOpRule nm (>)  [ boundsCmp Gt ]
 primOpRules nm WordGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]
@@ -284,29 +284,49 @@ mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)
 mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
             -> [RuleM CoreExpr] -> Maybe CoreRule
 mkRelOpRule nm cmp extra
-  = mkPrimOpRule nm 2 $ rules ++ extra
+  = mkPrimOpRule nm 2 $
+    binaryCmpLit cmp : equal_rule : extra
   where
-    rules = [ binaryCmpLit cmp
-            , do equalArgs
-              -- x `cmp` x does not depend on x, so
-              -- compute it for the arbitrary value 'True'
-              -- and use that result
-                 dflags <- getDynFlags
-                 return (if cmp True True
-                         then trueValInt  dflags
-                         else falseValInt dflags) ]
-
--- Note [Rules for floating-point comparisons]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- We need different rules for floating-point values because for floats
--- it is not true that x = x. The special case when this does not occur
--- are NaNs.
+        -- x `cmp` x does not depend on x, so
+        -- compute it for the arbitrary value 'True'
+        -- and use that result
+    equal_rule = do { equalArgs
+                    ; dflags <- getDynFlags
+                    ; return (if cmp True True
+                              then trueValInt  dflags
+                              else falseValInt dflags) }
+
+{- Note [Rules for floating-point comparisons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need different rules for floating-point values because for floats
+it is not true that x = x (for NaNs); so we do not want the equal_rule
+rule that mkRelOpRule uses.
+
+Note also that, in the case of equality/inequality, we do /not/
+want to switch to a case-expression.  For example, we do not want
+to convert
+   case (eqFloat# x 3.8#) of
+     True -> this
+     False -> that
+to
+  case x of
+    3.8#::Float# -> this
+    _            -> that
+See Trac #9238.  Reason: comparing floating-point values for equality
+delicate, and we don't want to implement that delicacy in the code for
+case expressions.  So we make it an invariant of Core that a case
+expression never scrutinises a Float# or Double#.
+
+This transformation is what the litEq rule does;
+see Note [The litEq rule: converting equality to case].
+So we /refrain/ from using litEq for mkFloatingRelOpRule.
+-}
 
 mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
-                    -> [RuleM CoreExpr] -> Maybe CoreRule
-mkFloatingRelOpRule nm cmp extra -- See Note [Rules for floating-point comparisons]
-  = mkPrimOpRule nm 2 $ binaryCmpLit cmp : extra
+                    -> Maybe CoreRule
+-- See Note [Rules for floating-point comparisons]
+mkFloatingRelOpRule nm cmp
+  = mkPrimOpRule nm 2 [binaryCmpLit cmp]
 
 -- common constants
 zeroi, onei, zerow, onew :: DynFlags -> Literal
@@ -428,24 +448,27 @@ doubleOp2 op dflags (MachDouble f1) (MachDouble f2)
 doubleOp2 _ _ _ _ = Nothing
 
 --------------------------
--- This stuff turns
---      n ==# 3#
--- into
---      case n of
---        3# -> True
---        m  -> False
---
--- This is a Good Thing, because it allows case-of case things
--- to happen, and case-default absorption to happen.  For
--- example:
---
---      if (n ==# 3#) || (n ==# 4#) then e1 else e2
--- will transform to
---      case n of
---        3# -> e1
---        4# -> e1
---        m  -> e2
--- (modulo the usual precautions to avoid duplicating e1)
+{- Note [The litEq rule: converting equality to case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This stuff turns
+     n ==# 3#
+into
+     case n of
+       3# -> True
+       m  -> False
+
+This is a Good Thing, because it allows case-of case things
+to happen, and case-default absorption to happen.  For
+example:
+
+     if (n ==# 3#) || (n ==# 4#) then e1 else e2
+will transform to
+     case n of
+       3# -> e1
+       4# -> e1
+       m  -> e2
+(modulo the usual precautions to avoid duplicating e1)
+-}
 
 litEq :: Bool  -- True <=> equality, False <=> inequality
       -> RuleM CoreExpr