compiler/main/CodeOutput.lhs

@@ -190,11 +190,8 @@ outputForeignStubs dflags mod location stubs
    stub_c <- newTempName dflags "c"
 
    case stubs of
-     NoStubs -> do
-        -- When compiling External Core files, may need to use stub
-        -- files from a previous compilation
-        stub_h_exists <- doesFileExist stub_h
-        return (stub_h_exists, Nothing)
+     NoStubs ->
+        return (False, Nothing)
 
      ForeignStubs h_code c_code -> do
         let

compiler/main/DriverPhases.hs

@@ -82,7 +82,7 @@ data Phase
         | HCc           -- Haskellised C (as opposed to vanilla C) compilation
         | Splitter      -- Assembly file splitter (part of '-split-objs')
         | SplitAs       -- Assembler for split assembly files (part of '-split-objs')
-        | As            -- Assembler for regular assembly files
+        | As Bool       -- Assembler for regular assembly files (Bool: with-cpp)
         | LlvmOpt       -- Run LLVM opt tool over llvm assembly
         | LlvmLlc       -- LLVM bitcode to native assembly
         | LlvmMangle    -- Fix up TNTC by processing assembly produced by LLVM
@@ -119,7 +119,7 @@ eqPhase Cobjcpp     Cobjcpp    = True
 eqPhase HCc         HCc        = True
 eqPhase Splitter    Splitter   = True
 eqPhase SplitAs     SplitAs    = True
-eqPhase As          As         = True
+eqPhase (As x)      (As y)     = x == y
 eqPhase LlvmOpt     LlvmOpt    = True
 eqPhase LlvmLlc     LlvmLlc    = True
 eqPhase LlvmMangle  LlvmMangle = True
@@ -150,21 +150,21 @@ nextPhase dflags p
       Splitter   -> SplitAs
       LlvmOpt    -> LlvmLlc
       LlvmLlc    -> LlvmMangle
-      LlvmMangle -> As
+      LlvmMangle -> As False
       SplitAs    -> MergeStub
-      As         -> MergeStub
-      Ccpp       -> As
-      Cc         -> As
-      Cobjc      -> As
-      Cobjcpp    -> As
+      As _       -> MergeStub
+      Ccpp       -> As False
+      Cc         -> As False
+      Cobjc      -> As False
+      Cobjcpp    -> As False
       CmmCpp     -> Cmm
       Cmm        -> maybeHCc
-      HCc        -> As
+      HCc        -> As False
       MergeStub  -> StopLn
       StopLn     -> panic "nextPhase: nothing after StopLn"
     where maybeHCc = if platformUnregisterised (targetPlatform dflags)
                      then HCc
-                     else As
+                     else As False
 
 -- the first compilation phase for a given file is determined
 -- by its suffix.
@@ -186,8 +186,8 @@ startPhase "mm"       = Cobjcpp
 startPhase "cc"       = Ccpp
 startPhase "cxx"      = Ccpp
 startPhase "split_s"  = Splitter
-startPhase "s"        = As
-startPhase "S"        = As
+startPhase "s"        = As False
+startPhase "S"        = As True
 startPhase "ll"       = LlvmOpt
 startPhase "bc"       = LlvmLlc
 startPhase "lm_s"     = LlvmMangle
@@ -215,7 +215,8 @@ phaseInputExt Cobjc               = "m"
 phaseInputExt Cobjcpp             = "mm"
 phaseInputExt Cc                  = "c"
 phaseInputExt Splitter            = "split_s"
-phaseInputExt As                  = "s"
+phaseInputExt (As True)           = "S"
+phaseInputExt (As False)          = "s"
 phaseInputExt LlvmOpt             = "ll"
 phaseInputExt LlvmLlc             = "bc"
 phaseInputExt LlvmMangle          = "lm_s"
@@ -240,14 +241,14 @@ objish_suffixes :: Platform -> [String]
 -- Use the appropriate suffix for the system on which
 -- the GHC-compiled code will run
 objish_suffixes platform = case platformOS platform of
-                           OSMinGW32 -> [ "o", "O", "obj", "OBJ" ]
-                           _         -> [ "o" ]
+  OSMinGW32 -> [ "o", "O", "obj", "OBJ" ]
+  _         -> [ "o" ]
 
 dynlib_suffixes :: Platform -> [String]
 dynlib_suffixes platform = case platformOS platform of
-                           OSMinGW32 -> ["dll", "DLL"]
-                           OSDarwin  -> ["dylib"]
-                           _         -> ["so"]
+  OSMinGW32 -> ["dll", "DLL"]
+  OSDarwin  -> ["dylib", "so"]
+  _         -> ["so"]
 
 isHaskellishSuffix, isHaskellSrcSuffix, isCishSuffix, isExtCoreSuffix,
     isHaskellUserSrcSuffix

compiler/main/DriverPipeline.hs

@@ -139,11 +139,13 @@ compileOne' m_tc_result mHscMessage
        input_fnpp  = ms_hspp_file summary
        mod_graph   = hsc_mod_graph hsc_env0
        needsTH     = any (xopt Opt_TemplateHaskell . ms_hspp_opts) mod_graph
+       needsQQ     = any (xopt Opt_QuasiQuotes     . ms_hspp_opts) mod_graph
+       needsLinker = needsTH || needsQQ
        isDynWay    = any (== WayDyn) (ways dflags0)
        isProfWay   = any (== WayProf) (ways dflags0)
    -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
    -- the linker can correctly load the object files.
-   let dflags1 = if needsTH && dynamicGhc && not isDynWay && not isProfWay
+   let dflags1 = if needsLinker && dynamicGhc && not isDynWay && not isProfWay
                   then gopt_set dflags0 Opt_BuildDynamicToo
                   else dflags0
 
@@ -496,8 +498,8 @@ compileFile hsc_env stop_phase (src, mb_phase) = do
          | otherwise = Persistent
 
         stop_phase' = case stop_phase of
-                        As | split -> SplitAs
-                        _          -> stop_phase
+                        As _ | split -> SplitAs
+                        _            -> stop_phase
 
    ( _, out_file) <- runPipeline stop_phase' hsc_env
                             (src, fmap RealPhase mb_phase) Nothing output
@@ -728,7 +730,7 @@ getOutputFilename stop_phase output basename dflags next_phase maybe_location
           -- sometimes, we keep output from intermediate stages
           keep_this_output =
                case next_phase of
-                       As      | keep_s     -> True
+                       As _    | keep_s     -> True
                        LlvmOpt | keep_bc    -> True
                        HCc     | keep_hc    -> True
                        _other               -> False
@@ -1043,7 +1045,7 @@ runPhase (RealPhase cc_phase) input_fn dflags
         -- files; this is the Value Add(TM) that using ghc instead of
         -- gcc gives you :)
         pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
-        let include_paths = foldr (\ x xs -> "-I" : x : xs) []
+        let include_paths = foldr (\ x xs -> ("-I" ++ x) : xs) []
                               (cmdline_include_paths ++ pkg_include_dirs)
 
         let gcc_extra_viac_flags = extraGccViaCFlags dflags
@@ -1076,7 +1078,7 @@ runPhase (RealPhase cc_phase) input_fn dflags
                    | otherwise            = []
 
         -- Decide next phase
-        let next_phase = As
+        let next_phase = As False
         output_fn <- phaseOutputFilename next_phase
 
         let
@@ -1188,7 +1190,7 @@ runPhase (RealPhase Splitter) input_fn dflags
 -- As, SpitAs phase : Assembler
 
 -- This is for calling the assembler on a regular assembly file (not split).
-runPhase (RealPhase As) input_fn dflags
+runPhase (RealPhase (As with_cpp)) input_fn dflags
   = do
         -- LLVM from version 3.0 onwards doesn't support the OS X system
         -- assembler, so we use clang as the assembler instead. (#5636)
@@ -1214,6 +1216,7 @@ runPhase (RealPhase As) input_fn dflags
         -- might be a hierarchical module.
         liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
 
+        ccInfo <- liftIO $ getCompilerInfo dflags
         let runAssembler inputFilename outputFilename
                 = liftIO $ as_prog dflags
                        ([ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
@@ -1228,8 +1231,13 @@ runPhase (RealPhase As) input_fn dflags
                        ++ (if platformArch (targetPlatform dflags) == ArchSPARC
                            then [SysTools.Option "-mcpu=v9"]
                            else [])
-
-                       ++ [ SysTools.Option "-x", SysTools.Option "assembler-with-cpp"
+                       ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51]
+                            then [SysTools.Option "-Qunused-arguments"]
+                            else [])
+                       ++ [ SysTools.Option "-x"
+                          , if with_cpp
+                              then SysTools.Option "assembler-with-cpp"
+                              else SysTools.Option "assembler"
                           , SysTools.Option "-c"
                           , SysTools.FileOption "" inputFilename
                           , SysTools.Option "-o"
@@ -1254,6 +1262,7 @@ runPhase (RealPhase SplitAs) _input_fn dflags
             osuf = objectSuf dflags
             split_odir  = base_o ++ "_" ++ osuf ++ "_split"
 
+        -- this also creates the hierarchy
         liftIO $ createDirectoryIfMissing True split_odir
 
         -- remove M_split/ *.o, because we're going to archive M_split/ *.o
@@ -1335,7 +1344,7 @@ runPhase (RealPhase LlvmOpt) input_fn dflags
         -- passes only, so if the user is passing us extra options we assume
         -- they know what they are doing and don't get in the way.
         optFlag  = if null (getOpts dflags opt_lo)
-                       then map SysTools.Option $ words (llvmOpts !! opt_lvl)
+                       then map SysTools.Option $ words (llvmOpts ver !! opt_lvl)
                        else []
         tbaa | ver < 29                 = "" -- no tbaa in 2.8 and earlier
              | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
@@ -1355,7 +1364,11 @@ runPhase (RealPhase LlvmOpt) input_fn dflags
   where 
         -- we always (unless -optlo specified) run Opt since we rely on it to
         -- fix up some pretty big deficiencies in the code we generate
-        llvmOpts = ["-mem2reg -globalopt", "-O1", "-O2"]
+        llvmOpts ver = [ "-mem2reg -globalopt"
+                       , if ver >= 34 then "-O1 -globalopt" else "-O1"
+                         -- LLVM 3.4 -O1 doesn't eliminate aliases reliably (bug #8855)
+                       , "-O2"
+                       ]
 
 -----------------------------------------------------------------------------
 -- LlvmLlc phase
@@ -1379,7 +1392,7 @@ runPhase (RealPhase LlvmLlc) input_fn dflags
     let next_phase = case gopt Opt_NoLlvmMangler dflags of
                          False                            -> LlvmMangle
                          True | gopt Opt_SplitObjs dflags -> Splitter
-                         True                             -> As
+                         True                             -> As False
                         
     output_fn <- phaseOutputFilename next_phase
 
@@ -1448,7 +1461,7 @@ runPhase (RealPhase LlvmLlc) input_fn dflags
 
 runPhase (RealPhase LlvmMangle) input_fn dflags
   = do
-      let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As
+      let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As False
       output_fn <- phaseOutputFilename next_phase
       liftIO $ llvmFixupAsm dflags input_fn output_fn
       return (RealPhase next_phase, output_fn)
@@ -1460,6 +1473,7 @@ runPhase (RealPhase MergeStub) input_fn dflags
  = do
      PipeState{maybe_stub_o} <- getPipeState
      output_fn <- phaseOutputFilename StopLn
+     liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
      case maybe_stub_o of
        Nothing ->
          panic "runPhase(MergeStub): no stub"
@@ -2128,26 +2142,27 @@ joinObjectFiles dflags o_files output_fn = do
   let mySettings = settings dflags
       ldIsGnuLd = sLdIsGnuLd mySettings
       osInfo = platformOS (targetPlatform dflags)
-      ld_r args ccInfo = SysTools.runLink dflags ([
-                            SysTools.Option "-nostdlib",
-                            SysTools.Option "-Wl,-r"
-                            ]
-                         ++ (if ccInfo == Clang then []
-                              else [SysTools.Option "-nodefaultlibs"])
-                         ++ (if osInfo == OSFreeBSD
-                              then [SysTools.Option "-L/usr/lib"]
-                              else [])
-                            -- gcc on sparc sets -Wl,--relax implicitly, but
-                            -- -r and --relax are incompatible for ld, so
-                            -- disable --relax explicitly.
-                         ++ (if platformArch (targetPlatform dflags) == ArchSPARC
-                             && ldIsGnuLd
-                                then [SysTools.Option "-Wl,-no-relax"]
-                                else [])
-                         ++ map SysTools.Option ld_build_id
-                         ++ [ SysTools.Option "-o",
-                              SysTools.FileOption "" output_fn ]
-                         ++ args)
+      ld_r args cc = SysTools.runLink dflags ([
+                       SysTools.Option "-nostdlib",
+                       SysTools.Option "-Wl,-r"
+                     ]
+                     ++ (if any (cc ==) [Clang, AppleClang, AppleClang51]
+                          then []
+                          else [SysTools.Option "-nodefaultlibs"])
+                     ++ (if osInfo == OSFreeBSD
+                          then [SysTools.Option "-L/usr/lib"]
+                          else [])
+                        -- gcc on sparc sets -Wl,--relax implicitly, but
+                        -- -r and --relax are incompatible for ld, so
+                        -- disable --relax explicitly.
+                     ++ (if platformArch (targetPlatform dflags) == ArchSPARC
+                         && ldIsGnuLd
+                            then [SysTools.Option "-Wl,-no-relax"]
+                            else [])
+                     ++ map SysTools.Option ld_build_id
+                     ++ [ SysTools.Option "-o",
+                          SysTools.FileOption "" output_fn ]
+                     ++ args)
 
       -- suppress the generation of the .note.gnu.build-id section,
       -- which we don't need and sometimes causes ld to emit a
@@ -2180,7 +2195,7 @@ hscPostBackendPhase dflags _ hsc_lang =
   case hsc_lang of
         HscC -> HCc
         HscAsm | gopt Opt_SplitObjs dflags -> Splitter
-               | otherwise                 -> As
+               | otherwise                 -> As False
         HscLlvm        -> LlvmOpt
         HscNothing     -> StopLn
         HscInterpreted -> StopLn

compiler/main/DynFlags.hs

@@ -1279,7 +1279,7 @@ initDynFlags dflags = do
  refRtccInfo <- newIORef Nothing
  wrapperNum <- newIORef emptyModuleEnv
  canUseUnicodeQuotes <- do let enc = localeEncoding
-                               str = "‛’"
+                               str = "‘’"
                            (withCString enc str $ \cstr ->
                                 do str' <- peekCString enc cstr
                                    return (str == str'))
@@ -3523,10 +3523,10 @@ picCCOpts dflags
           --     Don't generate "common" symbols - these are unwanted
           --     in dynamic libraries.
 
-       | gopt Opt_PIC dflags -> ["-fno-common", "-U __PIC__", "-D__PIC__"]
+       | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"]
        | otherwise           -> ["-mdynamic-no-pic"]
       OSMinGW32 -- no -fPIC for Windows
-       | gopt Opt_PIC dflags -> ["-U __PIC__", "-D__PIC__"]
+       | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"]
        | otherwise           -> []
       _
       -- we need -fPIC for C files when we are compiling with -dynamic,
@@ -3535,12 +3535,12 @@ picCCOpts dflags
       -- objects, but can't without -fPIC.  See
       -- http://ghc.haskell.org/trac/ghc/wiki/Commentary/PositionIndependentCode
        | gopt Opt_PIC dflags || not (gopt Opt_Static dflags) ->
-          ["-fPIC", "-U __PIC__", "-D__PIC__"]
+          ["-fPIC", "-U__PIC__", "-D__PIC__"]
        | otherwise                             -> []
 
 picPOpts :: DynFlags -> [String]
 picPOpts dflags
- | gopt Opt_PIC dflags = ["-U __PIC__", "-D__PIC__"]
+ | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"]
  | otherwise           = []
 
 -- -----------------------------------------------------------------------------
@@ -3749,6 +3749,8 @@ data LinkerInfo
 data CompilerInfo
    = GCC
    | Clang
+   | AppleClang
+   | AppleClang51
    | UnknownCC
    deriving Eq
 

compiler/main/GHC.hs

@@ -102,6 +102,7 @@ module GHC (
         parseName,
         RunResult(..),  
         runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
+        runTcInteractive,   -- Desired by some clients (Trac #8878)
         parseImportDecl, SingleStep(..),
         resume,
         Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
@@ -257,6 +258,7 @@ module GHC (
 import ByteCodeInstr
 import BreakArray
 import InteractiveEval
+import TcRnDriver       ( runTcInteractive )
 #endif
 
 import HscMain

compiler/main/HscMain.hs

@@ -1357,11 +1357,7 @@ hscStmtWithLocation hsc_env0 stmt source linenumber =
         Just parsed_stmt -> do
             -- Rename and typecheck it
             hsc_env <- getHscEnv
-            let interactive_hsc_env = setInteractivePackage hsc_env
-                  -- Bindings created here belong to the interactive package
-                  -- See Note [The interactive package] in HscTypes
-                  -- (NB: maybe not necessary, since Stmts bind only Ids)
-            (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt interactive_hsc_env parsed_stmt
+            (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env parsed_stmt
 
             -- Desugar it
             ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
@@ -1397,10 +1393,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
 
     {- Rename and typecheck it -}
     hsc_env <- getHscEnv
-    let interactive_hsc_env = setInteractivePackage hsc_env
-            -- Bindings created here belong to the interactive package
-            -- See Note [The interactive package] in HscTypes
-    tc_gblenv <- ioMsgMaybe $ tcRnDeclsi interactive_hsc_env decls
+    tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls
 
     {- Grab the new instances -}
     -- We grab the whole environment because of the overlapping that may have

compiler/main/HscStats.hs

@@ -132,7 +132,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     class_info decl@(ClassDecl {})
         = (classops, addpr (sum3 (map count_bind methods)))
       where
-        methods = map (unLoc . snd) $ bagToList (tcdMeths decl)
+        methods = map unLoc $ bagToList (tcdMeths decl)
         (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl))
     class_info _ = (0,0)
 
@@ -147,7 +147,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
                   (addpr (sum3 (map count_bind methods)),
                    ss, is, length ats, length adts)
       where
-        methods = map (unLoc . snd) $ bagToList inst_meths
+        methods = map unLoc $ bagToList inst_meths
 
     -- TODO: use Sum monoid
     addpr :: (Int,Int,Int) -> Int

compiler/main/HscTypes.lhs

@@ -1119,10 +1119,10 @@ shadowed by the second declaration.  But it has a respectable
 qualified name (Ghci1.T), and its source location says where it was
 defined.
 
-So the main invariant continues to hold, that in any session an original
-name M.T only refers to oe unique thing.  (In a previous iteration both
-the T's above were called :Interactive.T, albeit with different uniques,
-which gave rise to all sorts of trouble.)
+So the main invariant continues to hold, that in any session an
+original name M.T only refers to one unique thing.  (In a previous
+iteration both the T's above were called :Interactive.T, albeit with
+different uniques, which gave rise to all sorts of trouble.)
 
 The details are a bit tricky though:
 
@@ -1132,7 +1132,7 @@ The details are a bit tricky though:
  * ic_tythings contains only things from the 'interactive' package.
 
  * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go
-   in the Home Package Table (HPT).  When you say :load, that's when
+   in the Home Package Table (HPT).  When you say :load, that's when we
    extend the HPT.
 
  * The 'thisPackage' field of DynFlags is *not* set to 'interactive'.
@@ -1140,10 +1140,13 @@ The details are a bit tricky though:
    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?  By setting 'thisPackage' just
-   before the typecheck/rename step for command-line processing;
-   see the calls to HscTypes.setInteractivePackage in
-   HscMain.hscDeclsWithLocation and hscStmtWithLocation.
+   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.
+
+   The 'thisPackage' field stays as 'main' (or whatever -package-name says.
 
  * The main trickiness is that the type environment (tcg_type_env and
    fixity envt (tcg_fix_env) now contains entities from all the
@@ -1501,15 +1504,17 @@ implicitTyThings :: TyThing -> [TyThing]
 implicitTyThings (AnId _)       = []
 implicitTyThings (ACoAxiom _cc) = []
 implicitTyThings (ATyCon tc)    = implicitTyConThings tc
-implicitTyThings (AConLike cl)  = case cl of
-    RealDataCon dc ->
-        -- For data cons add the worker and (possibly) wrapper
-        map AnId (dataConImplicitIds dc)
-    PatSynCon ps ->
-        -- For bidirectional pattern synonyms, add the wrapper
-        case patSynWrapper ps of
-            Nothing -> []
-            Just id -> [AnId id]
+implicitTyThings (AConLike cl)  = implicitConLikeThings cl
+
+implicitConLikeThings :: ConLike -> [TyThing]
+implicitConLikeThings (RealDataCon dc)
+  = map AnId (dataConImplicitIds dc)
+    -- For data cons add the worker and (possibly) wrapper
+
+implicitConLikeThings (PatSynCon {})
+  = []  -- Pattern synonyms have no implicit Ids; the wrapper and matcher
+        -- are not "implicit"; they are simply new top-level bindings,
+        -- and they have their own declaration in an interface fiel
 
 implicitClassThings :: Class -> [TyThing]
 implicitClassThings cl

compiler/main/Packages.lhs

@@ -1047,10 +1047,22 @@ isDllName :: DynFlags -> PackageId -> Module -> Name -> Bool
 -- Despite the "dll", I think this function just means that
 -- the synbol comes from another dynamically-linked package,
 -- and applies on all platforms, not just Windows
-isDllName dflags this_pkg this_mod name
+isDllName dflags _this_pkg this_mod name
   | gopt Opt_Static dflags = False
   | Just mod <- nameModule_maybe name
-    = if modulePackageId mod /= this_pkg
+    -- Issue #8696 - when GHC is dynamically linked, it will attempt
+    -- to load the dynamic dependencies of object files at compile
+    -- time for things like QuasiQuotes or
+    -- TemplateHaskell. Unfortunately, this interacts badly with
+    -- intra-package linking, because we don't generate indirect
+    -- (dynamic) symbols for intra-package calls. This means that if a
+    -- module with an intra-package call is loaded without its
+    -- dependencies, then GHC fails to link. This is the cause of #
+    --
+    -- In the mean time, always force dynamic indirections to be
+    -- generated: when the module name isn't the module being
+    -- compiled, references are dynamic.
+    = if mod /= this_mod
       then True
       else case dllSplit dflags of
            Nothing -> False

compiler/main/PprTyThing.hs

@@ -23,20 +23,18 @@ module PprTyThing (
   ) where
 
 import TypeRep ( TyThing(..) )
-import ConLike
 import DataCon
-import PatSyn
 import Id
 import TyCon
 import Class
-import Coercion( pprCoAxiom, pprCoAxBranch )
+import Coercion( pprCoAxBranch )
 import CoAxiom( CoAxiom(..), brListMap )
 import HscTypes( tyThingParent_maybe )
-import HsBinds( pprPatSynSig )
 import Type( tidyTopType, tidyOpenType, splitForAllTys, funResultTy )
 import Kind( synTyConResKind )
 import TypeRep( pprTvBndrs, pprForAll, suppressKinds )
 import TysPrim( alphaTyVars )
+import MkIface ( tyThingToIfaceDecl )
 import TcType
 import Name
 import VarEnv( emptyTidyEnv )
@@ -44,7 +42,6 @@ import StaticFlags( opt_PprStyle_Debug )
 import DynFlags
 import Outputable
 import FastString
-import Data.Maybe
 
 -- -----------------------------------------------------------------------------
 -- Pretty-printing entities that we get from the GHC API
@@ -76,7 +73,7 @@ pprTyThingLoc tyThing
 
 -- | Pretty-prints a 'TyThing'.
 pprTyThing :: TyThing -> SDoc
-pprTyThing thing = ppr_ty_thing showAll thing
+pprTyThing thing = ppr_ty_thing (Just showAll) thing
 
 -- | Pretty-prints a 'TyThing' in context: that is, if the entity
 -- is a data constructor, record selector, or class method, then
@@ -88,7 +85,7 @@ pprTyThingInContext thing
   where
     go ss thing = case tyThingParent_maybe thing of
                     Just parent -> go (getName thing : ss) parent
-                    Nothing     -> ppr_ty_thing ss thing
+                    Nothing     -> ppr_ty_thing (Just ss) thing
 
 -- | Like 'pprTyThingInContext', but adds the defining location.
 pprTyThingInContextLoc :: TyThing -> SDoc
@@ -100,21 +97,18 @@ pprTyThingInContextLoc tyThing
 -- the function is equivalent to 'pprTyThing' but for type constructors
 -- and classes it prints only the header part of the declaration.
 pprTyThingHdr :: TyThing -> SDoc
-pprTyThingHdr (AnId id)          = pprId         id
-pprTyThingHdr (AConLike conLike) = case conLike of
-    RealDataCon dataCon -> pprDataConSig dataCon
-    PatSynCon patSyn    -> pprPatSyn     patSyn
-pprTyThingHdr (ATyCon tyCon)     = pprTyConHdr   tyCon
-pprTyThingHdr (ACoAxiom ax)      = pprCoAxiom ax
+pprTyThingHdr = ppr_ty_thing Nothing
 
 ------------------------
-ppr_ty_thing :: ShowSub -> TyThing -> SDoc
-ppr_ty_thing _  (AnId id)          = pprId         id
-ppr_ty_thing _  (AConLike conLike) = case conLike of
-    RealDataCon dataCon -> pprDataConSig dataCon
-    PatSynCon patSyn    -> pprPatSyn     patSyn
-ppr_ty_thing ss (ATyCon tyCon)     = pprTyCon      ss tyCon
-ppr_ty_thing _  (ACoAxiom ax)      = pprCoAxiom    ax
+-- NOTE: We pretty-print 'TyThing' via 'IfaceDecl' so that we can reuse the
+-- 'TyCon' tidying happening in 'tyThingToIfaceDecl'. See #8776 for details.
+ppr_ty_thing :: Maybe ShowSub -> TyThing -> SDoc
+ppr_ty_thing mss tyThing = case tyThing of
+    AnId id -> pprId id
+    ATyCon tyCon -> case mss of
+        Nothing -> pprTyConHdr tyCon
+        Just ss -> pprTyCon ss tyCon
+    _ -> ppr $ tyThingToIfaceDecl tyThing
 
 pprTyConHdr :: TyCon -> SDoc
 pprTyConHdr tyCon
@@ -133,7 +127,7 @@ pprTyConHdr tyCon
 
     keyword | isSynTyCon tyCon = sLit "type"
             | isNewTyCon tyCon = sLit "newtype"
-            | otherwise            = sLit "data"
+            | otherwise        = sLit "data"
 
     opt_family
       | isFamilyTyCon tyCon = ptext (sLit "family")
@@ -143,10 +137,6 @@ pprTyConHdr tyCon
 	| isAlgTyCon tyCon = pprThetaArrowTy (tyConStupidTheta tyCon)
 	| otherwise	   = empty	-- Returns 'empty' if null theta
 
-pprDataConSig :: DataCon -> SDoc
-pprDataConSig dataCon
-  = ppr_bndr dataCon <+> dcolon <+> pprTypeForUser (dataConUserType dataCon)
-
 pprClassHdr :: Class -> SDoc
 pprClassHdr cls
   = sdocWithDynFlags $ \dflags ->
@@ -163,23 +153,6 @@ pprId ident
   = hang (ppr_bndr ident <+> dcolon)
 	 2 (pprTypeForUser (idType ident))
 
-pprPatSyn :: PatSyn -> SDoc
-pprPatSyn patSyn
-  = pprPatSynSig ident is_bidir args (pprTypeForUser rhs_ty) prov req
-  where
-    ident = patSynId patSyn
-    is_bidir = isJust $ patSynWrapper patSyn
-
-    args = fmap pprParendType (patSynTyDetails patSyn)
-    prov = pprThetaOpt prov_theta
-    req = pprThetaOpt req_theta
-
-    pprThetaOpt [] = Nothing
-    pprThetaOpt theta = Just $ pprTheta theta
-
-    (_univ_tvs, _ex_tvs, (prov_theta, req_theta)) = patSynSig patSyn
-    rhs_ty = patSynType patSyn
-
 pprTypeForUser :: Type -> SDoc
 -- We do two things here.
 -- a) We tidy the type, regardless

compiler/main/SysTools.lhs

@@ -233,6 +233,8 @@ initSysTools mbMinusB
        -- to make that possible, so for now you can't.
        gcc_prog <- getSetting "C compiler command"
        gcc_args_str <- getSetting "C compiler flags"
+       cpp_prog <- getSetting "Haskell CPP command"
+       cpp_args_str <- getSetting "Haskell CPP flags"
        let unreg_gcc_args = if targetUnregisterised
                             then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
                             else []
@@ -241,6 +243,7 @@ initSysTools mbMinusB
             | mkTablesNextToCode targetUnregisterised
                = ["-DTABLES_NEXT_TO_CODE"]
             | otherwise = []
+           cpp_args= map Option (words cpp_args_str)
            gcc_args = map Option (words gcc_args_str
                                ++ unreg_gcc_args
                                ++ tntc_gcc_args)
@@ -283,10 +286,7 @@ initSysTools mbMinusB
        -- cpp is derived from gcc on all platforms
        -- HACK, see setPgmP below. We keep 'words' here to remember to fix
        -- Config.hs one day.
-       let cpp_prog  = gcc_prog
-           cpp_args  = Option "-E"
-                     : map Option (words cRAWCPP_FLAGS)
-                    ++ gcc_args
+
 
        -- Other things being equal, as and ld are simply gcc
        gcc_link_args_str <- getSetting "C compiler link flags"
@@ -602,6 +602,42 @@ figureLlvmVersion dflags = do
                 return Nothing)
   return ver
 
+{- Note [Windows stack usage]
+
+See: Trac #8870 (and #8834 for related info)
+
+On Windows, occasionally we need to grow the stack. In order to do
+this, we would normally just bump the stack pointer - but there's a
+catch on Windows.
+
+If the stack pointer is bumped by more than a single page, then the
+pages between the initial pointer and the resulting location must be
+properly committed by the Windows virtual memory subsystem. This is
+only needed in the event we bump by more than one page (i.e 4097 bytes
+or more).
+
+Windows compilers solve this by emitting a call to a special function
+called _chkstk, which does this committing of the pages for you.
+
+The reason this was causing a segfault was because due to the fact the
+new code generator tends to generate larger functions, we needed more
+stack space in GHC itself. In the x86 codegen, we needed approximately
+~12kb of stack space in one go, which caused the process to segfault,
+as the intervening pages were not committed.
+
+In the future, we should do the same thing, to make the problem
+completely go away. In the mean time, we're using a workaround: we
+instruct the linker to specify the generated PE as having an initial
+reserved stack size of 8mb, as well as a initial *committed* stack
+size of 8mb. The default committed size was previously only 4k.
+
+Theoretically it's possible to still hit this problem if you request a
+stack bump of more than 8mb in one go. But the amount of code
+necessary is quite large, and 8mb "should be more than enough for
+anyone" right now (he said, before millions of lines of code cried out
+in terror).
+
+-}
 
 {- Note [Run-time linker info]
 
@@ -691,15 +727,20 @@ getLinkerInfo' dflags = do
                  -- that doesn't support --version. We can just assume that's
                  -- what we're using.
                  return $ DarwinLD []
-               OSiOS -> 
+               OSiOS ->
                  -- Ditto for iOS
                  return $ DarwinLD []
                OSMinGW32 ->
                  -- GHC doesn't support anything but GNU ld on Windows anyway.
                  -- Process creation is also fairly expensive on win32, so
                  -- we short-circuit here.
-                 return $ GnuLD $ map Option ["-Wl,--hash-size=31",
-                                              "-Wl,--reduce-memory-overheads"]
+                 return $ GnuLD $ map Option
+                   [ -- Reduce ld memory usage
+                     "-Wl,--hash-size=31"
+                   , "-Wl,--reduce-memory-overheads"
+                     -- Increase default stack, see
+                     -- Note [Windows stack usage]
+                   , "-Xlinker", "--stack=0x800000,0x800000" ]
                _ -> do
                  -- In practice, we use the compiler as the linker here. Pass
                  -- -Wl,--version to get linker version info.
@@ -745,12 +786,15 @@ getCompilerInfo' dflags = do
         -- Regular clang
         | any ("clang version" `isPrefixOf`) stde =
           return Clang
+        -- XCode 5.1 clang
+        | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =
+          return AppleClang51
         -- XCode 5 clang
         | any ("Apple LLVM version" `isPrefixOf`) stde =
-          return Clang
+          return AppleClang
         -- XCode 4.1 clang
         | any ("Apple clang version" `isPrefixOf`) stde =
-          return Clang
+          return AppleClang
          -- Unknown linker.
         | otherwise = fail "invalid -v output, or compiler is unsupported"
 

compiler/main/TidyPgm.lhs

@@ -559,7 +559,7 @@ Oh: two other reasons for injecting them late:
 There is one sort of implicit binding that is injected still later,
 namely those for data constructor workers. Reason (I think): it's
 really just a code generation trick.... binding itself makes no sense.
-See CorePrep Note [Data constructor workers].
+See Note [Data constructor workers] in CorePrep.
 
 \begin{code}
 getTyConImplicitBinds :: TyCon -> [CoreBind]

compiler/nativeGen/PIC.hs

@@ -728,9 +728,10 @@ initializePicBase_ppc ArchPPC os picReg
 
             fetchPC (BasicBlock bID insns) =
               BasicBlock bID (PPC.FETCHPC picReg
+                              : PPC.ADDIS tmp picReg (PPC.HI offsetToOffset)
                               : PPC.LD PPC.archWordSize tmp
-                                   (PPC.AddrRegImm picReg offsetToOffset)
-                              : PPC.ADD picReg picReg (PPC.RIReg tmp)
+                                   (PPC.AddrRegImm tmp (PPC.LO offsetToOffset))
+                              : PPC.ADD picReg picReg (PPC.RIReg picReg)
                               : insns)
 
         return (CmmProc info lab live (ListGraph blocks') : gotOffset : statics)

compiler/nativeGen/RegAlloc/Liveness.hs

@@ -665,14 +665,20 @@ sccBlocks
 
 sccBlocks blocks entries = map (fmap get_node) sccs
   where
-        sccs = stronglyConnCompFromG graph roots
-
-        graph = graphFromEdgedVertices nodes
-
         -- nodes :: [(NatBasicBlock instr, Unique, [Unique])]
         nodes = [ (block, id, getOutEdges instrs)
                 | block@(BasicBlock id instrs) <- blocks ]
 
+        g1 = graphFromEdgedVertices nodes
+
+        reachable :: BlockSet
+        reachable = setFromList [ id | (_,id,_) <- reachablesG g1 roots ]
+
+        g2 = graphFromEdgedVertices [ node | node@(_,id,_) <- nodes
+                                           , id `setMember` reachable ]
+
+        sccs = stronglyConnCompG g2
+
         get_node (n, _, _) = n
 
         getOutEdges :: Instruction instr => [instr] -> [BlockId]

compiler/nativeGen/X86/Regs.hs

@@ -403,6 +403,9 @@ callClobberedRegs       :: Platform -> [Reg]
 -- caller-saves registers
 callClobberedRegs platform
  | target32Bit platform = [eax,ecx,edx] ++ map regSingle (floatregnos platform)
+ | platformOS platform == OSMinGW32
+   = [rax,rcx,rdx,r8,r9,r10,r11]
+   ++ map regSingle (floatregnos platform)
  | otherwise
     -- all xmm regs are caller-saves
     -- caller-saves registers

compiler/parser/Parser.y.pp

@@ -1151,10 +1151,11 @@ atype :: { LHsType RdrName }
         | TH_ID_SPLICE                   { LL $ mkHsSpliceTy $ L1 $ HsVar $
                                            mkUnqual varName (getTH_ID_SPLICE $1) }
                                                       -- see Note [Promotion] for the followings
-        | SIMPLEQUOTE qconid                          { LL $ HsTyVar $ unLoc $2 }
-        | SIMPLEQUOTE  '(' ')'                        { LL $ HsTyVar $ getRdrName unitDataCon }
+        | SIMPLEQUOTE qcon                            { LL $ HsTyVar $ unLoc $2 }
         | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')' { LL $ HsExplicitTupleTy [] ($3 : $5) }
         | SIMPLEQUOTE  '[' comma_types0 ']'           { LL $ HsExplicitListTy placeHolderKind $3 }
+        | SIMPLEQUOTE var                             { LL $ HsTyVar $ unLoc $2 }
+
         | '[' ctype ',' comma_types1 ']'              { LL $ HsExplicitListTy placeHolderKind ($2 : $4) }
         | INTEGER            {% mkTyLit $ LL $ HsNumTy $ getINTEGER $1 }
         | STRING             {% mkTyLit $ LL $ HsStrTy $ getSTRING  $1 }
@@ -1475,18 +1476,18 @@ infixexp :: { LHsExpr RdrName }
 
 exp10 :: { LHsExpr RdrName }
         : '\\' apat apats opt_asig '->' exp
-                        { LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4
+                        { LL $ HsLam (mkMatchGroup FromSource [LL $ Match ($2:$3) $4
                                                                 (unguardedGRHSs $6)
-                                                            ]) }
+                                                              ]) }
         | 'let' binds 'in' exp                  { LL $ HsLet (unLoc $2) $4 }
         | '\\' 'lcase' altslist
-            { LL $ HsLamCase placeHolderType (mkMatchGroup (unLoc $3)) }
+            { LL $ HsLamCase placeHolderType (mkMatchGroup FromSource (unLoc $3)) }
         | 'if' exp optSemi 'then' exp optSemi 'else' exp
                                         {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
                                            return (LL $ mkHsIf $2 $5 $8) }
         | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>
                                            return (LL $ HsMultiIf placeHolderType (reverse $ unLoc $2)) }
-        | 'case' exp 'of' altslist              { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
+        | 'case' exp 'of' altslist              { LL $ HsCase $2 (mkMatchGroup FromSource (unLoc $4)) }
         | '-' fexp                              { LL $ NegApp $2 noSyntaxExpr }
 
         | 'do' stmtlist                 { L (comb2 $1 $2) (mkHsDo DoExpr  (unLoc $2)) }

compiler/parser/RdrHsSyn.lhs

@@ -315,7 +315,7 @@ cvBindsAndSigs  fb = go (fromOL fb)
     go []                  = (emptyBag, [], [], [], [], [])
     go (L l (SigD s) : ds) = (bs, L l s : ss, ts, tfis, dfis, docs)
                            where (bs, ss, ts, tfis, dfis, docs) = go ds
-    go (L l (ValD b) : ds) = ((FromSource, b') `consBag` bs, ss, ts, tfis, dfis, docs)
+    go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, tfis, dfis, docs)
                            where (b', ds')    = getMonoBind (L l b) ds
                                  (bs, ss, ts, tfis, dfis, docs) = go ds'
     go (L l (TyClD (FamDecl t)) : ds) = (bs, ss, L l t : ts, tfis, dfis, docs)
@@ -735,7 +735,7 @@ checkFunBind msg lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
 makeFunBind :: Located id -> Bool -> [LMatch id (LHsExpr id)] -> HsBind id
 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 makeFunBind fn is_infix ms
-  = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
+  = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup FromSource ms,
               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
 
 checkPatBind :: SDoc

compiler/prelude/PrelNames.lhs

@@ -37,55 +37,70 @@ Nota Bene: all Names defined in here should come from the base package
 
 Note [Known-key names]
 ~~~~~~~~~~~~~~~~~~~~~~
+It is *very* important that the compiler gives wired-in things and
+things with "known-key" names the correct Uniques wherever they
+occur. We have to be careful about this in exactly two places:
 
-It is *very* important that the compiler gives wired-in things and things with "known-key" names
-the correct Uniques wherever they occur. We have to be careful about this in exactly two places:
+  1. When we parse some source code, renaming the AST better yield an
+     AST whose Names have the correct uniques
 
-  1. When we parse some source code, renaming the AST better yield an AST whose Names have the
-     correct uniques
-
-  2. When we read an interface file, the read-in gubbins better have the right uniques
+  2. When we read an interface file, the read-in gubbins better have
+     the right uniques
 
 This is accomplished through a combination of mechanisms:
 
-  1. When parsing source code, the RdrName-decorated AST has some RdrNames which are Exact. These are
-     wired-in RdrNames where the we could directly tell from the parsed syntax what Name to use. For
-     example, when we parse a [] in a type we can just insert an Exact RdrName Name with the listTyConKey.
-
-     Currently, I believe this is just an optimisation: it would be equally valid to just output Orig
-     RdrNames that correctly record the module etc we expect the final Name to come from. However,
-     were we to eliminate isTupleOcc_maybe it would become essential (see point 3).
-
-  2. The knownKeyNames (which consist of the basicKnownKeyNames from the module, and those names reachable
-     via the wired-in stuff from TysWiredIn) are used to initialise the "original name cache" in IfaceEnv.
-     This initialization ensures that when the type checker or renamer (both of which use IfaceEnv) look up
-     an original name (i.e. a pair of a Module and an OccName) for a known-key name they get the correct Unique.
+  1. When parsing source code, the RdrName-decorated AST has some
+     RdrNames which are Exact. These are wired-in RdrNames where the
+     we could directly tell from the parsed syntax what Name to
+     use. For example, when we parse a [] in a type we can just insert
+     an Exact RdrName Name with the listTyConKey.
+
+     Currently, I believe this is just an optimisation: it would be
+     equally valid to just output Orig RdrNames that correctly record
+     the module etc we expect the final Name to come from. However,
+     were we to eliminate isBuiltInOcc_maybe it would become essential
+     (see point 3).
+
+  2. The knownKeyNames (which consist of the basicKnownKeyNames from
+     the module, and those names reachable via the wired-in stuff from
+     TysWiredIn) are used to initialise the "OrigNameCache" in
+     IfaceEnv.  This initialization ensures that when the type checker
+     or renamer (both of which use IfaceEnv) look up an original name
+     (i.e. a pair of a Module and an OccName) for a known-key name
+     they get the correct Unique.
+
+     This is the most important mechanism for ensuring that known-key
+     stuff gets the right Unique, and is why it is so important to
+     place your known-key names in the appropriate lists.
+
+  3. For "infinite families" of known-key names (i.e. tuples), we have
+     to be extra careful. Because there are an infinite number of
+     these things, we cannot add them to the list of known-key names
+     used to initialise the OrigNameCache. Instead, we have to
+     rely on never having to look them up in that cache.
 
-     This is the most important mechanism for ensuring that known-key stuff gets the right Unique, and is why
-     it is so important to place your known-key names in the appropriate lists.
+     This is accomplished through a variety of mechanisms:
 
-  3. For "infinite families" of known-key names (i.e. tuples, Any tycons and implicit parameter TyCons), we
-     have to be extra careful. Because there are an infinite number of these things, we cannot add them to
-     the list of known-key names used to initialise the original name cache. Instead, we have to rely on
-     never having to look them up in that cache.
+       a) The parser recognises them specially and generates an 
+          Exact Name (hence not looked up in the orig-name cache)
 
-     This is accomplished through a variety of mechanisms:
+       b) The known infinite families of names are specially
+          serialised by BinIface.putName, with that special treatment
+          detected when we read back to ensure that we get back to the
+          correct uniques.
 
-       a) The known infinite families of names are specially serialised by BinIface.putName, with that special treatment
-          detected when we read back to ensure that we get back to the correct uniques.
+       Most of the infinite families cannot occur in source code,
+       so mechanisms (a,b) sufficies to ensure that they always have
+       the right Unique. In particular, implicit param TyCon names,
+       constraint tuples and Any TyCons cannot be mentioned by the
+       user.
 
-       b) Most of the infinite families cannot occur in source code, so mechanism a) sufficies to ensure that they
-          always have the right Unique. In particular, implicit param TyCon names, constraint tuples and Any TyCons
-          cannot be mentioned by the user.
+       c) IfaceEnv.lookupOrigNameCache uses isBuiltInOcc_maybe to map
+          built-in syntax directly onto the corresponding name, rather
+          than trying to find it in the original-name cache.
 
-       c) Tuple TyCon/DataCon names have a special hack (isTupleOcc_maybe) that is used by the original name cache
-          lookup routine to detect tuple names and give them the right Unique. You might think that this is unnecessary
-          because tuple TyCon/DataCons are parsed as Exact RdrNames and *don't* appear as original names in interface files
-          (because serialization gives them special treatment), so we will never look them up in the original name cache.
+          See also Note [Built-in syntax and the OrigNameCache]
 
-          However, there is a subtle reason why this is not the case: if you use setRdrNameSpace on an Exact RdrName
-          it may be turned into an Orig RdrName. So if the original name was an Exact tuple Name we might end up with
-          an Orig instead, which *will* lead to an original name cache query.
 \begin{code}
 module PrelNames (
         Unique, Uniquable(..), hasKey,  -- Re-exported for convenience
@@ -250,8 +265,6 @@ basicKnownKeyNames
         concatName, filterName, mapName,
         zipName, foldrName, buildName, augmentName, appendName,
 
-        dollarName,         -- The ($) apply function
-
         -- FFI primitive types that are not wired-in.
         stablePtrTyConName, ptrTyConName, funPtrTyConName,
         int8TyConName, int16TyConName, int32TyConName, int64TyConName,
@@ -476,10 +489,10 @@ mkMainModule_ m = mkModule mainPackageId m
 %************************************************************************
 
 \begin{code}
-mkTupleModule :: TupleSort -> Arity -> Module
-mkTupleModule BoxedTuple   _ = gHC_TUPLE
-mkTupleModule ConstraintTuple    _ = gHC_TUPLE
-mkTupleModule UnboxedTuple _ = gHC_PRIM
+mkTupleModule :: TupleSort -> Module
+mkTupleModule BoxedTuple      = gHC_TUPLE
+mkTupleModule ConstraintTuple = gHC_TUPLE
+mkTupleModule UnboxedTuple    = gHC_PRIM
 \end{code}
 
 
@@ -851,7 +864,7 @@ groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey
 fromStringName, otherwiseIdName, foldrName, buildName, augmentName,
     mapName, appendName, assertName,
     breakpointName, breakpointCondName, breakpointAutoName,
-    dollarName, opaqueTyConName :: Name
+    opaqueTyConName :: Name
 fromStringName = methName dATA_STRING (fsLit "fromString") fromStringClassOpKey
 otherwiseIdName   = varQual gHC_BASE (fsLit "otherwise")  otherwiseIdKey
 foldrName         = varQual gHC_BASE (fsLit "foldr")      foldrIdKey
@@ -859,7 +872,6 @@ buildName         = varQual gHC_BASE (fsLit "build")      buildIdKey
 augmentName       = varQual gHC_BASE (fsLit "augment")    augmentIdKey
 mapName           = varQual gHC_BASE (fsLit "map")        mapIdKey
 appendName        = varQual gHC_BASE (fsLit "++")         appendIdKey
-dollarName        = varQual gHC_BASE (fsLit "$")          dollarIdKey
 assertName        = varQual gHC_BASE (fsLit "assert")     assertIdKey
 breakpointName    = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey
 breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey
@@ -1475,6 +1487,7 @@ rep1TyConKey = mkPreludeTyConUnique 156
 typeNatKindConNameKey, typeSymbolKindConNameKey,
   typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,
   typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey
+  , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey
   :: Unique
 typeNatKindConNameKey     = mkPreludeTyConUnique 160
 typeSymbolKindConNameKey  = mkPreludeTyConUnique 161
@@ -1483,6 +1496,8 @@ typeNatMulTyFamNameKey    = mkPreludeTyConUnique 163
 typeNatExpTyFamNameKey    = mkPreludeTyConUnique 164
 typeNatLeqTyFamNameKey    = mkPreludeTyConUnique 165
 typeNatSubTyFamNameKey    = mkPreludeTyConUnique 166
+typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 167
+typeNatCmpTyFamNameKey    = mkPreludeTyConUnique 168
 
 ntTyConKey:: Unique
 ntTyConKey = mkPreludeTyConUnique 174

compiler/prelude/TysWiredIn.lhs

@@ -8,7 +8,7 @@
 --   must be wired into the compiler nonetheless.  C.f module TysPrim
 module TysWiredIn (
         -- * All wired in things
-        wiredInTyCons,
+        wiredInTyCons, isBuiltInOcc_maybe,
 
         -- * Bool
         boolTy, boolTyCon, boolTyCon_RDR, boolTyConName,
@@ -20,6 +20,8 @@ module TysWiredIn (
         ltDataCon, ltDataConId,
         eqDataCon, eqDataConId,
         gtDataCon, gtDataConId,
+        promotedOrderingTyCon,
+        promotedLTDataCon, promotedEQDataCon, promotedGTDataCon,
 
         -- * Char
         charTyCon, charDataCon, charTyCon_RDR,
@@ -329,11 +331,11 @@ typeSymbolKind = TyConApp (promoteTyCon typeSymbolKindCon) []
 
 %************************************************************************
 %*                                                                      *
-\subsection[TysWiredIn-tuples]{The tuple types}
+                Stuff for dealing with tuples
 %*                                                                      *
 %************************************************************************
 
-Note [How tuples work]
+Note [How tuples work]  See also Note [Known-key names] in PrelNames
 ~~~~~~~~~~~~~~~~~~~~~~
 * There are three families of tuple TyCons and corresponding
   DataCons, (boxed, unboxed, and constraint tuples), expressed by the
@@ -352,6 +354,68 @@ Note [How tuples work]
   are not serialised into interface files using OccNames at all.
 
 \begin{code}
+isBuiltInOcc_maybe :: OccName -> Maybe Name
+-- Built in syntax isn't "in scope" so these OccNames 
+-- map to wired-in Names with BuiltInSyntax
+isBuiltInOcc_maybe occ
+  = case occNameString occ of
+        "[]"             -> choose_ns listTyCon nilDataCon
+        ":"              -> Just consDataConName
+        "[::]"           -> Just parrTyConName
+        "(##)"           -> choose_ns unboxedUnitTyCon unboxedUnitDataCon
+        "()"             -> choose_ns unitTyCon        unitDataCon
+        '(':'#':',':rest -> parse_tuple UnboxedTuple 2 rest
+        '(':',':rest     -> parse_tuple BoxedTuple   2 rest
+        _other           -> Nothing
+  where
+    ns = occNameSpace occ
+
+    parse_tuple sort n rest
+      | (',' : rest2) <- rest   = parse_tuple sort (n+1) rest2
+      | tail_matches sort rest  = choose_ns (tupleTyCon sort n)
+                                            (tupleCon   sort n)
+      | otherwise               = Nothing
+
+    tail_matches BoxedTuple   ")"  = True
+    tail_matches UnboxedTuple "#)" = True
+    tail_matches _            _    = False
+  
+    choose_ns tc dc
+      | isTcClsNameSpace ns   = Just (getName tc)
+      | isDataConNameSpace ns = Just (getName dc)
+      | otherwise             = Just (getName (dataConWorkId dc))
+
+mkTupleOcc :: NameSpace -> TupleSort -> Arity -> OccName
+mkTupleOcc ns sort ar = mkOccName ns str
+  where
+    -- No need to cache these, the caching is done in mk_tuple
+    str = case sort of
+                UnboxedTuple    -> '(' : '#' : commas ++ "#)"
+                BoxedTuple      -> '(' : commas ++ ")"
+                ConstraintTuple -> '(' : commas ++ ")"
+
+    commas = take (ar-1) (repeat ',')
+
+    -- Cute hack: we reuse the standard tuple OccNames (and hence code)
+    -- for fact tuples, but give them different Uniques so they are not equal.
+    --
+    -- You might think that this will go wrong because isBuiltInOcc_maybe won't
+    -- be able to tell the difference between boxed tuples and constraint tuples. BUT:
+    --  1. Constraint tuples never occur directly in user code, so it doesn't matter
+    --     that we can't detect them in Orig OccNames originating from the user
+    --     programs (or those built by setRdrNameSpace used on an Exact tuple Name)
+    --  2. Interface files have a special representation for tuple *occurrences*
+    --     in IfaceTyCons, their workers (in IfaceSyn) and their DataCons (in case
+    --     alternatives). Thus we don't rely on the OccName to figure out what kind
+    --     of tuple an occurrence was trying to use in these situations.
+    --  3. We *don't* represent tuple data type declarations specially, so those
+    --     are still turned into wired-in names via isBuiltInOcc_maybe. But that's OK
+    --     because we don't actually need to declare constraint tuples thanks to this hack.
+    --
+    -- So basically any OccName like (,,) flowing to isBuiltInOcc_maybe will always
+    -- refer to the standard boxed tuple. Cool :-)
+
+
 tupleTyCon :: TupleSort -> Arity -> TyCon
 tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i)  -- Build one specially
 tupleTyCon BoxedTuple   i = fst (boxedTupleArr   ! i)
@@ -384,7 +448,7 @@ mk_tuple sort arity = (tycon, tuple_con)
           UnboxedTuple    -> Nothing
           ConstraintTuple -> Nothing
 
-        modu    = mkTupleModule sort arity
+        modu    = mkTupleModule sort
         tc_name = mkWiredInName modu (mkTupleOcc tcName sort arity) tc_uniq
                                 (ATyCon tycon) BuiltInSyntax
         tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind
@@ -831,5 +895,19 @@ promotedTrueDataCon   = promoteDataCon trueDataCon
 promotedFalseDataCon  = promoteDataCon falseDataCon
 \end{code}
 
+Promoted Ordering
+
+\begin{code}
+promotedOrderingTyCon
+  , promotedLTDataCon
+  , promotedEQDataCon
+  , promotedGTDataCon
+  :: TyCon
+promotedOrderingTyCon = promoteTyCon orderingTyCon
+promotedLTDataCon     = promoteDataCon ltDataCon
+promotedEQDataCon     = promoteDataCon eqDataCon
+promotedGTDataCon     = promoteDataCon gtDataCon
+\end{code}
+
 
 

compiler/rename/RnBinds.lhs

@@ -47,7 +47,7 @@ import NameSet
 import RdrName          ( RdrName, rdrNameOcc )
 import SrcLoc
 import ListSetOps	( findDupsEq )
-import BasicTypes	( RecFlag(..), Origin )
+import BasicTypes	( RecFlag(..) )
 import Digraph		( SCC(..) )
 import Bag
 import Outputable
@@ -275,7 +275,7 @@ rnValBindsLHS :: NameMaker
               -> HsValBinds RdrName
               -> RnM (HsValBindsLR Name RdrName)
 rnValBindsLHS topP (ValBindsIn mbinds sigs)
-  = do { mbinds' <- mapBagM (wrapOriginLocM (rnBindLHS topP doc)) mbinds
+  = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds
        ; return $ ValBindsIn mbinds' sigs }
   where
     bndrs = collectHsBindsBinders mbinds
@@ -434,19 +434,26 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = name@(L nameLoc _) })
        ; return (bind { fun_id = L nameLoc newname }) } 
 
 rnBindLHS name_maker _ bind@(PatSynBind{ patsyn_id = rdrname@(L nameLoc _) })
-  = do { addLocM checkConName rdrname
+  = do { unless (isTopRecNameMaker name_maker) $
+           addErr localPatternSynonymErr
+       ; addLocM checkConName rdrname
        ; name <- applyNameMaker name_maker rdrname
        ; return (bind{ patsyn_id = L nameLoc name }) }
+  where
+    localPatternSynonymErr :: SDoc
+    localPatternSynonymErr
+      = hang (ptext (sLit "Illegal pattern synonym declaration"))
+           2 (ptext (sLit "Pattern synonym declarations are only valid in the top-level scope"))
 
 rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
 
 rnLBind :: (Name -> [Name])		-- Signature tyvar function
-        -> (Origin, LHsBindLR Name RdrName)
-        -> RnM ((Origin, LHsBind Name), [Name], Uses)
-rnLBind sig_fn (origin, (L loc bind))
+        -> LHsBindLR Name RdrName
+        -> RnM (LHsBind Name, [Name], Uses)
+rnLBind sig_fn (L loc bind)
   = setSrcSpan loc $
     do { (bind', bndrs, dus) <- rnBind sig_fn bind
-       ; return ((origin, L loc bind'), bndrs, dus) }
+       ; return (L loc bind', bndrs, dus) }
 
 -- assumes the left-hands-side vars are in scope
 rnBind :: (Name -> [Name])		-- Signature tyvar function
@@ -574,7 +581,7 @@ trac ticket #1136.
 -}
 
 ---------------------
-depAnalBinds :: Bag ((Origin, LHsBind Name), [Name], Uses)
+depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
 	     -> ([(RecFlag, LHsBinds Name)], DefUses)
 -- Dependency analysis; this is important so that 
 -- unused-binding reporting is accurate
@@ -659,10 +666,9 @@ rnMethodBinds cls sig_fn binds
        ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) }
   where 
     meth_names  = collectMethodBinders binds
-    do_one (binds,fvs) (origin,bind)
+    do_one (binds,fvs) bind
        = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind
-            ; let bind'' = mapBag (\bind -> (origin,bind)) bind'
-	    ; return (binds `unionBags` bind'', fvs_bind `plusFV` fvs) }
+	    ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
 
 rnMethodBind :: Name
 	      -> (Name -> [Name])
@@ -670,7 +676,7 @@ rnMethodBind :: Name
 	      -> RnM (Bag (LHsBindLR Name Name), FreeVars)
 rnMethodBind cls sig_fn 
              (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix 
-				  , fun_matches = MG { mg_alts = matches } }))
+				  , fun_matches = MG { mg_alts = matches, mg_origin = origin } }))
   = setSrcSpan loc $ do
     sel_name <- wrapLocM (lookupInstDeclBndr cls (ptext (sLit "method"))) name
     let plain_name = unLoc sel_name
@@ -678,7 +684,7 @@ rnMethodBind cls sig_fn
 
     (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
                           mapFvRn (rnMatch (FunRhs plain_name is_infix) rnLExpr) matches
-    let new_group = mkMatchGroup new_matches
+    let new_group = mkMatchGroup origin new_matches
 
     when is_infix $ checkPrecMatch plain_name new_group
     return (unitBag (L loc (bind { fun_id      = sel_name 
@@ -882,11 +888,11 @@ rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name
              -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
              -> MatchGroup RdrName (Located (body RdrName))
              -> RnM (MatchGroup Name (Located (body Name)), FreeVars)
-rnMatchGroup ctxt rnBody (MG { mg_alts = ms }) 
+rnMatchGroup ctxt rnBody (MG { mg_alts = ms, mg_origin = origin }) 
   = do { empty_case_ok <- xoptM Opt_EmptyCase
        ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
        ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
-       ; return (mkMatchGroup new_ms, ms_fvs) }
+       ; return (mkMatchGroup origin new_ms, ms_fvs) }
 
 rnMatch :: Outputable (body RdrName) => HsMatchContext Name
         -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))