compiler/main/DriverPipeline.hs

@@ -1183,14 +1183,17 @@ runPhase As input_fn dflags
                         = do
                             llvmVer <- io $ figureLlvmVersion dflags
                             return $ case llvmVer of
-                                Just n | n >= 30 -> SysTools.runClang
-                                _                -> SysTools.runAs
+                                -- using cGccLinkerOpts here but not clear if
+                                -- opt_c isn't a better choice
+                                Just n | n >= 30 ->
+                                    (SysTools.runClang, cGccLinkerOpts)
+
+                                _ -> (SysTools.runAs, getOpts dflags opt_a)
 
                         | otherwise
-                        = return SysTools.runAs
+                        = return (SysTools.runAs, getOpts dflags opt_a)
 
-        as_prog <- whichAsProg
-        let as_opts = getOpts dflags opt_a
+        (as_prog, as_opts) <- whichAsProg
         let cmdline_include_paths = includePaths dflags
 
         next_phase <- maybeMergeStub
@@ -1198,7 +1201,7 @@ runPhase As input_fn dflags
 
         -- we create directories for the object file, because it
         -- might be a hierarchical module.
-        io $ createDirectoryHierarchy (takeDirectory output_fn)
+        io $ createDirectoryIfMissing True (takeDirectory output_fn)
 
         io $ as_prog dflags
                        (map SysTools.Option as_opts
@@ -1237,7 +1240,7 @@ runPhase SplitAs _input_fn dflags
             osuf = objectSuf dflags
             split_odir  = base_o ++ "_" ++ osuf ++ "_split"
 
-        io $ createDirectoryHierarchy split_odir
+        io $ createDirectoryIfMissing True split_odir
 
         -- remove M_split/ *.o, because we're going to archive M_split/ *.o
         -- later and we don't want to pick up any old objects.
@@ -2126,6 +2129,6 @@ hscPostBackendPhase dflags _ hsc_lang =
 
 touchObjectFile :: DynFlags -> FilePath -> IO ()
 touchObjectFile dflags path = do
-  createDirectoryHierarchy $ takeDirectory path
+  createDirectoryIfMissing True $ takeDirectory path
   SysTools.touch dflags "Touching object file" path
 

compiler/main/DynFlags.hs

@@ -31,6 +31,7 @@ module DynFlags (
         DynFlags(..),
         RtsOptsEnabled(..),
         HscTarget(..), isObjectTarget, defaultObjectTarget,
+        targetRetainsAllBindings,
         GhcMode(..), isOneShot,
         GhcLink(..), isNoLink,
         PackageFlag(..),
@@ -44,6 +45,7 @@ module DynFlags (
         safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn,
         packageTrustOn,
         safeDirectImpsReq, safeImplicitImpsReq,
+        unsafeFlags,
 
         -- ** System tool settings and locations
         Settings(..),
@@ -402,6 +404,7 @@ data ExtensionFlag
    | Opt_RebindableSyntax
    | Opt_ConstraintKinds
    | Opt_PolyKinds                -- Kind polymorphism
+   | Opt_DataKinds                -- Datatype promotion
 
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable
@@ -562,11 +565,12 @@ data DynFlags = DynFlags {
   language              :: Maybe Language,
   -- | Safe Haskell mode
   safeHaskell           :: SafeHaskellMode,
-  -- We store the location of where template haskell and newtype deriving were
-  -- turned on so we can produce accurate error messages when Safe Haskell turns
-  -- them off.
+  -- We store the location of where some extension and flags were turned on so
+  -- we can produce accurate error messages when Safe Haskell fails due to
+  -- them.
   thOnLoc               :: SrcSpan,
   newDerivOnLoc         :: SrcSpan,
+  pkgTrustOnLoc         :: SrcSpan,
   warnSafeOnLoc         :: SrcSpan,
   warnUnsafeOnLoc       :: SrcSpan,
   -- Don't change this without updating extensionFlags:
@@ -737,6 +741,17 @@ isObjectTarget HscAsm   = True
 isObjectTarget HscLlvm  = True
 isObjectTarget _        = False
 
+-- | Does this target retain *all* top-level bindings for a module,
+-- rather than just the exported bindings, in the TypeEnv and compiled
+-- code (if any)?  In interpreted mode we do this, so that GHCi can
+-- call functions inside a module.  In HscNothing mode we also do it,
+-- so that Haddock can get access to the GlobalRdrEnv for a module
+-- after typechecking it.
+targetRetainsAllBindings :: HscTarget -> Bool
+targetRetainsAllBindings HscInterpreted = True
+targetRetainsAllBindings HscNothing     = True
+targetRetainsAllBindings _              = False
+
 -- | The 'GhcMode' tells us whether we're doing multi-module
 -- compilation (controlled via the "GHC" API) or one-shot
 -- (single-module) compilation.  This makes a difference primarily to
@@ -906,6 +921,7 @@ defaultDynFlags mySettings =
         safeHaskell = Sf_SafeInfered,
         thOnLoc = noSrcSpan,
         newDerivOnLoc = noSrcSpan,
+        pkgTrustOnLoc = noSrcSpan,
         warnSafeOnLoc = noSrcSpan,
         warnUnsafeOnLoc = noSrcSpan,
         extensions = [],
@@ -1098,6 +1114,19 @@ combineSafeFlags a b | a == Sf_SafeInfered = return b
     where errm = "Incompatible Safe Haskell flags! ("
                     ++ showPpr a ++ ", " ++ showPpr b ++ ")"
 
+-- | A list of unsafe flags under Safe Haskell. Tuple elements are:
+--     * name of the flag
+--     * function to get srcspan that enabled the flag
+--     * function to test if the flag is on
+--     * function to turn the flag off
+unsafeFlags :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]
+unsafeFlags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc,
+                   xopt Opt_GeneralizedNewtypeDeriving,
+                   flip xopt_unset Opt_GeneralizedNewtypeDeriving),
+               ("-XTemplateHaskell", thOnLoc,
+                   xopt Opt_TemplateHaskell,
+                   flip xopt_unset Opt_TemplateHaskell)]
+
 -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
 getOpts :: DynFlags             -- ^ 'DynFlags' to retrieve the options from
         -> (DynFlags -> [a])    -- ^ Relevant record accessor: one of the @opt_*@ accessors
@@ -1301,19 +1330,28 @@ parseDynamicFlags dflags0 args cmdline = do
   when (not (null errs)) $ ghcError $ errorsToGhcException errs
 
   -- check for disabled flags in safe haskell
-  let (dflags2, sh_warns) = safeFlagCheck dflags1
+  let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1
 
   return (dflags2, leftover, sh_warns ++ warns)
 
 -- | Check (and potentially disable) any extensions that aren't allowed
 -- in safe mode.
-safeFlagCheck :: DynFlags -> (DynFlags, [Located String])
-safeFlagCheck dflags | not (safeLanguageOn dflags || safeInferOn dflags)
-                     = (dflags, [])
-safeFlagCheck dflags =
+safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String])
+safeFlagCheck _  dflags | not (safeLanguageOn dflags || safeInferOn dflags)
+                        = (dflags, [])
+
+safeFlagCheck cmdl dflags =
     case safeLanguageOn dflags of
         True -> (dflags', warns)
 
+        -- throw error if -fpackage-trust by itself with no safe haskell flag
+        False | not cmdl && safeInferOn dflags && packageTrustOn dflags
+              -> (dopt_unset dflags' Opt_PackageTrust,
+                  [L (pkgTrustOnLoc dflags') $
+                      "Warning: -fpackage-trust ignored;" ++
+                      " must be specified with a Safe Haskell flag"]
+                  )
+
         False | null warns && safeInfOk
               -> (dflags', [])
 
@@ -1325,10 +1363,10 @@ safeFlagCheck dflags =
         -- TODO: Can we do better than this for inference?
         safeInfOk = not $ xopt Opt_OverlappingInstances dflags
 
-        (dflags', warns) = foldl check_method (dflags, []) bad_flags
+        (dflags', warns) = foldl check_method (dflags, []) unsafeFlags
 
         check_method (df, warns) (str,loc,test,fix)
-            | test df   = (apFix fix df, warns ++ safeFailure loc str)
+            | test df   = (apFix fix df, warns ++ safeFailure (loc dflags) str)
             | otherwise = (df, warns)
 
         apFix f = if safeInferOn dflags then id else f
@@ -1336,14 +1374,6 @@ safeFlagCheck dflags =
         safeFailure loc str = [L loc $ "Warning: " ++ str ++ " is not allowed in"
                                       ++ " Safe Haskell; ignoring " ++ str]
 
-        bad_flags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc dflags,
-                         xopt Opt_GeneralizedNewtypeDeriving,
-                         flip xopt_unset Opt_GeneralizedNewtypeDeriving),
-                     ("-XTemplateHaskell", thOnLoc dflags,
-                         xopt Opt_TemplateHaskell,
-                         flip xopt_unset Opt_TemplateHaskell)]
-
-
 {- **********************************************************************
 %*                                                                      *
                 DynFlags specifications
@@ -1659,7 +1689,7 @@ dynamic_flags = [
   , Flag "fno-glasgow-exts" (NoArg (disableGlasgowExts >> deprecate "Use individual extensions instead"))
 
         ------ Safe Haskell flags -------------------------------------------
-  , Flag "fpackage-trust"   (NoArg (setDynFlag Opt_PackageTrust))
+  , Flag "fpackage-trust"   (NoArg setPackageTrust)
   , Flag "fno-safe-infer"   (NoArg (setSafeHaskell Sf_None))
  ]
  ++ map (mkFlag turnOn  "f"    setDynFlag  ) fFlags
@@ -1934,6 +1964,7 @@ xFlags = [
   ( "RebindableSyntax",                 Opt_RebindableSyntax, nop ),
   ( "ConstraintKinds",                  Opt_ConstraintKinds, nop ),
   ( "PolyKinds",                        Opt_PolyKinds, nop ),
+  ( "DataKinds",                        Opt_DataKinds, nop ),
   ( "MonoPatBinds",                     Opt_MonoPatBinds,
     \ turn_on -> when turn_on $ deprecate "Experimental feature now removed; has no effect" ),
   ( "ExplicitForAll",                   Opt_ExplicitForAll, nop ),
@@ -2020,8 +2051,6 @@ impliedFlags
     , (Opt_TypeFamilies,     turnOn, Opt_KindSignatures)  -- Type families use kind signatures
                                                           -- all over the place
 
-    , (Opt_PolyKinds,        turnOn, Opt_KindSignatures)
-
     , (Opt_ImpredicativeTypes,  turnOn, Opt_RankNTypes)
 
         -- Record wild-cards implies field disambiguation
@@ -2171,6 +2200,12 @@ setWarnUnsafe :: Bool -> DynP ()
 setWarnUnsafe True  = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l })
 setWarnUnsafe False = return ()
 
+setPackageTrust :: DynP ()
+setPackageTrust = do
+    setDynFlag Opt_PackageTrust
+    l <- getCurLoc
+    upd $ \d -> d { pkgTrustOnLoc = l }
+
 setGenDeriving :: Bool -> DynP ()
 setGenDeriving True  = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l })
 setGenDeriving False = return ()

compiler/main/ErrUtils.lhs

@@ -7,6 +7,7 @@
 
 module ErrUtils (
         Message, mkLocMessage, printError, pprMessageBag, pprErrMsgBag,
+        pprErrMsgBagWithLoc,
         Severity(..),
 
         ErrMsg, WarnMsg,
@@ -40,6 +41,7 @@ import SrcLoc
 import DynFlags
 import StaticFlags      ( opt_ErrorSpans )
 
+import System.Directory
 import System.Exit      ( ExitCode(..), exitWith )
 import System.FilePath
 import Data.List
@@ -152,6 +154,15 @@ pprErrMsgBag bag
                errMsgExtraInfo = e,
                errMsgContext   = unqual } <- sortMsgBag bag ]
 
+pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
+pprErrMsgBagWithLoc bag
+  = [ let style = mkErrStyle unqual
+      in withPprStyle style (mkLocMessage s (d $$ e))
+    | ErrMsg { errMsgSpans     = s:_,
+               errMsgShortDoc  = d,
+               errMsgExtraInfo = e,
+               errMsgContext   = unqual } <- sortMsgBag bag ]
+
 printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO ()
 printMsgBag dflags bag sev
   = sequence_ [ let style = mkErrStyle unqual
@@ -234,7 +245,7 @@ dumpSDoc dflags dflag hdr doc
                             mode = if append then AppendMode else WriteMode
                         when (not append) $
                             writeIORef gdref (Set.insert fileName gd)
-                        createDirectoryHierarchy (takeDirectory fileName)
+                        createDirectoryIfMissing True (takeDirectory fileName)
                         handle <- openFile fileName mode
                         hPrintDump handle doc
                         hClose handle

compiler/main/GHC.hs

@@ -55,13 +55,16 @@ module GHC (
         TypecheckedMod, ParsedMod,
         moduleInfo, renamedSource, typecheckedSource,
         parsedSource, coreModule,
+
+        -- ** Compiling to Core
+        CoreModule(..),
         compileToCoreModule, compileToCoreSimplified,
         compileCoreToObj,
-        getModSummary,
 
 	-- * Inspecting the module structure of the program
 	ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
-	getModuleGraph,
+        getModSummary,
+        getModuleGraph,
 	isLoaded,
 	topSortModuleGraph,
 

compiler/main/HscMain.hs

@@ -60,6 +60,7 @@ module HscMain
     , hscParseIdentifier
     , hscTcRcLookupName
     , hscTcRnGetInfo
+    , hscCheckSafe
 #ifdef GHCI
     , hscGetModuleInterface
     , hscRnImportDecls
@@ -886,9 +887,8 @@ hscFileFrontEnd mod_summary = do
 -- inference mode.
 hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
 hscCheckSafeImports tcg_env = do
-    hsc_env  <- getHscEnv
     dflags   <- getDynFlags
-    tcg_env' <- checkSafeImports dflags hsc_env tcg_env
+    tcg_env' <- checkSafeImports dflags tcg_env
     case safeLanguageOn dflags of
         True -> do
             -- we nuke user written RULES in -XSafe
@@ -911,22 +911,20 @@ hscCheckSafeImports tcg_env = do
             text "Rule \"" <> ftext n <> text "\" ignored" $+$
             text "User defined rules are disabled under Safe Haskell"
 
--- | Validate that safe imported modules are actually safe.
--- For modules in the HomePackage (the package the module we
--- are compiling in resides) this just involves checking its
--- trust type is 'Safe' or 'Trustworthy'. For modules that
--- reside in another package we also must check that the
--- external pacakge is trusted. See the Note [Safe Haskell
--- Trust Check] above for more information.
+-- | Validate that safe imported modules are actually safe.  For modules in the
+-- HomePackage (the package the module we are compiling in resides) this just
+-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
+-- that reside in another package we also must check that the external pacakge
+-- is trusted. See the Note [Safe Haskell Trust Check] above for more
+-- information.
 --
--- The code for this is quite tricky as the whole algorithm
--- is done in a few distinct phases in different parts of the
--- code base. See RnNames.rnImportDecl for where package trust
--- dependencies for a module are collected and unioned.
--- Specifically see the Note [RnNames . Tracking Trust Transitively]
--- and the Note [RnNames . Trust Own Package].
-checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv
-checkSafeImports dflags hsc_env tcg_env
+-- The code for this is quite tricky as the whole algorithm is done in a few
+-- distinct phases in different parts of the code base. See
+-- RnNames.rnImportDecl for where package trust dependencies for a module are
+-- collected and unioned.  Specifically see the Note [RnNames . Tracking Trust
+-- Transitively] and the Note [RnNames . Trust Own Package].
+checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
+checkSafeImports dflags tcg_env
     = do
         -- We want to use the warning state specifically for detecting if safe
         -- inference has failed, so store and clear any existing warnings.
@@ -941,7 +939,7 @@ checkSafeImports dflags hsc_env tcg_env
         clearWarnings
         logWarnings oldErrs
 
-        -- See the Note [ Safe Haskell Inference]
+        -- See the Note [Safe Haskell Inference]
         case (not $ isEmptyBag errs) of
 
             -- We have errors!
@@ -953,7 +951,7 @@ checkSafeImports dflags hsc_env tcg_env
 
             -- All good matey!
             False -> do
-                when (packageTrustOn dflags) $ checkPkgTrust pkg_reqs
+                when (packageTrustOn dflags) $ checkPkgTrust dflags pkg_reqs
                 -- add in trusted package requirements for this module
                 let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs }
                 return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust }
@@ -981,40 +979,32 @@ checkSafeImports dflags hsc_env tcg_env
               (text $ "is imported both as a safe and unsafe import!"))
         | otherwise
         = return v1
+    
+    -- easier interface to work with
+    checkSafe (_, _, False) = return Nothing
+    checkSafe (m, l, True ) = hscCheckSafe' dflags m l
 
-    lookup' :: Module -> Hsc (Maybe ModIface)
-    lookup' m = do
-        hsc_eps <- liftIO $ hscEPS hsc_env
-        let pkgIfaceT = eps_PIT hsc_eps
-            homePkgT = hsc_HPT hsc_env
-            iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
-        return iface
-
-    isHomePkg :: Module -> Bool
-    isHomePkg m
-        | thisPackage dflags == modulePackageId m = True
-        | otherwise                               = False
-
-    -- | Check the package a module resides in is trusted.
-    -- Safe compiled modules are trusted without requiring
-    -- that their package is trusted. For trustworthy modules,
-    -- modules in the home package are trusted but otherwise
-    -- we check the package trust flag.
-    packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
-    packageTrusted _ _ _
-        | not (packageTrustOn dflags)     = True
-    packageTrusted Sf_Safe        False _ = True
-    packageTrusted Sf_SafeInfered False _ = True
-    packageTrusted _ _ m
-        | isHomePkg m = True
-        | otherwise   = trusted $ getPackageDetails (pkgState dflags)
-                                                    (modulePackageId m)
-
-    -- Is a module trusted? Return Nothing if True, or a String
-    -- if it isn't, containing the reason it isn't. Also return
-    -- if the module trustworthy (true) or safe (false) so we know
-    -- if we should check if the package itself is trusted in the
-    -- future.
+-- | Check that a module is safe to import.
+--
+-- We return a package id if the safe import is OK and a Nothing otherwise
+-- with the reason for the failure printed out.
+hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO (Maybe PackageId)
+hscCheckSafe hsc_env m l = runHsc hsc_env $ do
+    dflags <- getDynFlags
+    hscCheckSafe' dflags m l
+
+hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId)
+hscCheckSafe' dflags m l = do
+    tw <- isModSafe m l
+    case tw of
+        False              -> return Nothing
+        True | isHomePkg m -> return Nothing
+             | otherwise   -> return $ Just $ modulePackageId m
+  where
+    -- Is a module trusted? Return Nothing if True, or a String if it isn't,
+    -- containing the reason it isn't. Also return if the module trustworthy
+    -- (true) or safe (false) so we know if we should check if the package
+    -- itself is trusted in the future.
     isModSafe :: Module -> SrcSpan -> Hsc (Bool)
     isModSafe m l = do
         iface <- lookup' m
@@ -1039,38 +1029,60 @@ checkSafeImports dflags hsc_env tcg_env
                     (False, _   ) -> logWarnings modTrustErr >> return (trust == Sf_Trustworthy)
 
                 where
-                    pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $ ppr m
-                        <+> text "can't be safely imported!" <+> text "The package ("
-                        <> ppr (modulePackageId m)
-                        <> text ") the module resides in isn't trusted."
-                    modTrustErr = unitBag $ mkPlainErrMsg l $ ppr m
-                        <+> text "can't be safely imported!"
-                        <+> text "The module itself isn't safe."
-
-    -- Here we check the transitive package trust requirements are OK still.
-    checkPkgTrust :: [PackageId] -> Hsc ()
-    checkPkgTrust pkgs =
-        case errors of
-            [] -> return ()
-            _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors
-        where
-            errors = catMaybes $ map go pkgs
-            go pkg
-                | trusted $ getPackageDetails (pkgState dflags) pkg
-                = Nothing
-                | otherwise
-                = Just $ mkPlainErrMsg noSrcSpan
-                       $ text "The package (" <> ppr pkg <> text ") is required"
-                      <> text " to be trusted but it isn't!"
-
-    checkSafe :: (Module, SrcSpan, IsSafeImport) -> Hsc (Maybe PackageId)
-    checkSafe (_, _, False) = return Nothing
-    checkSafe (m, l, True ) = do
-        tw <- isModSafe m l
-        return $ pkg tw
-        where pkg False = Nothing
-              pkg True | isHomePkg m = Nothing
-                           | otherwise   = Just (modulePackageId m)
+                    pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $
+                        sep [ ppr (moduleName m) <> text ":"
+                            , text "Can't be safely imported!"
+                            , text "The package (" <> ppr (modulePackageId m)
+                                  <> text ") the module resides in isn't trusted."
+                            ]
+                    modTrustErr = unitBag $ mkPlainErrMsg l $
+                        sep [ ppr (moduleName m) <> text ":"
+                            , text "Can't be safely imported!"
+                            , text "The module itself isn't safe." ]
+
+    -- | Check the package a module resides in is trusted. Safe compiled
+    -- modules are trusted without requiring that their package is trusted. For
+    -- trustworthy modules, modules in the home package are trusted but
+    -- otherwise we check the package trust flag.
+    packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
+    packageTrusted _ _ _
+        | not (packageTrustOn dflags)     = True
+    packageTrusted Sf_Safe        False _ = True
+    packageTrusted Sf_SafeInfered False _ = True
+    packageTrusted _ _ m
+        | isHomePkg m = True
+        | otherwise   = trusted $ getPackageDetails (pkgState dflags)
+                                                    (modulePackageId m)
+
+    lookup' :: Module -> Hsc (Maybe ModIface)
+    lookup' m = do
+        hsc_env <- getHscEnv
+        hsc_eps <- liftIO $ hscEPS hsc_env
+        let pkgIfaceT = eps_PIT hsc_eps
+            homePkgT  = hsc_HPT hsc_env
+            iface     = lookupIfaceByModule dflags homePkgT pkgIfaceT m
+        return iface
+
+    isHomePkg :: Module -> Bool
+    isHomePkg m
+        | thisPackage dflags == modulePackageId m = True
+        | otherwise                               = False
+
+-- | Check the list of packages are trusted.
+checkPkgTrust :: DynFlags -> [PackageId] -> Hsc ()
+checkPkgTrust dflags pkgs =
+    case errors of
+        [] -> return ()
+        _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors
+    where
+        errors = catMaybes $ map go pkgs
+        go pkg
+            | trusted $ getPackageDetails (pkgState dflags) pkg
+            = Nothing
+            | otherwise
+            = Just $ mkPlainErrMsg noSrcSpan
+                   $ text "The package (" <> ppr pkg <> text ") is required"
+                  <> text " to be trusted but it isn't!"
 
 -- | Set module to unsafe and wipe trust information.
 --
@@ -1083,18 +1095,28 @@ wipeTrust tcg_env whyUnsafe = do
 
     when (wopt Opt_WarnUnsafe dflags)
          (logWarnings $ unitBag $
-             mkPlainWarnMsg (warnUnsafeOnLoc dflags) whyUnsafe')
+             mkPlainWarnMsg (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
 
     liftIO $ hscSetSafeInf env False
     return $ tcg_env { tcg_imports = wiped_trust }
 
   where
-    wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
-    pprMod      = ppr $ moduleName $ tcg_mod tcg_env
-    whyUnsafe'  = vcat [ text "Warning:" <+> quotes pprMod
+    wiped_trust   = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
+    pprMod        = ppr $ moduleName $ tcg_mod tcg_env
+    whyUnsafe' df = vcat [ text "Warning:" <+> quotes pprMod
                              <+> text "has been infered as unsafe!"
                        , text "Reason:"
-                       , nest 4 (vcat $ pprErrMsgBag whyUnsafe) ]
+                       , nest 4 $
+                           (vcat $ badFlags df) $+$
+                           (vcat $ pprErrMsgBagWithLoc whyUnsafe)
+                       ]
+
+    badFlags df   = concat $ map (badFlag df) unsafeFlags
+
+    badFlag df (str,loc,on,_)
+        | on df     = [mkLocMessage (loc df) $
+                            text str <+> text "is not allowed in Safe Haskell"]
+        | otherwise = []
 
 
 --------------------------------------------------------------

compiler/main/HscTypes.lhs

@@ -92,7 +92,7 @@ module HscTypes (
 
         -- * Vectorisation information
         VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo,
-        noIfaceVectInfo,
+        noIfaceVectInfo, isNoIfaceVectInfo,
 
         -- * Safe Haskell information
         hscGetSafeInf, hscSetSafeInf,
@@ -696,8 +696,8 @@ data ModIface
         mi_insts       :: [IfaceInst],     -- ^ Sorted class instance
         mi_fam_insts   :: [IfaceFamInst],  -- ^ Sorted family instances
         mi_rules       :: [IfaceRule],     -- ^ Sorted rules
-        mi_orphan_hash :: !Fingerprint,    -- ^ Hash for orphan rules and class
-                                           -- and family instances combined
+        mi_orphan_hash :: !Fingerprint,    -- ^ Hash for orphan rules, class and family
+                                           -- instances, and vectorise pragmas combined
 
         mi_vect_info :: !IfaceVectInfo,    -- ^ Vectorisation information
 
@@ -1543,6 +1543,8 @@ lookupFixity env n = case lookupNameEnv env n of
 --
 -- * A transformation rule in a module other than the one defining
 --   the function in the head of the rule
+--
+-- * A vectorisation pragma
 type WhetherHasOrphans   = Bool
 
 -- | Does this module define family instances?
@@ -1986,6 +1988,10 @@ concatVectInfo = foldr plusVectInfo noVectInfo
 noIfaceVectInfo :: IfaceVectInfo
 noIfaceVectInfo = IfaceVectInfo [] [] [] [] []
 
+isNoIfaceVectInfo :: IfaceVectInfo -> Bool
+isNoIfaceVectInfo (IfaceVectInfo l1 l2 l3 l4 l5)
+  = null l1 && null l2 && null l3 && null l4 && null l5
+
 instance Outputable VectInfo where
   ppr info = vcat
              [ ptext (sLit "variables     :") <+> ppr (vectInfoVar          info)

compiler/main/SysTools.lhs

@@ -192,6 +192,7 @@ initSysTools mbMinusB
                                 Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
         ; targetArch <- readSetting "target arch"
         ; targetOS <- readSetting "target os"
+        ; targetWordSize <- readSetting "target word size"
         ; targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
         ; targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
         ; myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
@@ -256,6 +257,7 @@ initSysTools mbMinusB
                         sTargetPlatform = Platform {
                                               platformArch = targetArch,
                                               platformOS   = targetOS,
+                                              platformWordSize = targetWordSize,
                                               platformHasGnuNonexecStack = targetHasGnuNonexecStack,
                                               platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols
                                           },

compiler/main/TidyPgm.lhs

@@ -505,12 +505,15 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar          = vars
          , vectInfoScalarVars   = tidy_scalarVars
          }
   where
-      -- we only export mappings whose co-domain is exported (otherwise, the iface is inconsistent)
+      -- we only export mappings whose domain and co-domain is exported (otherwise, the iface is
+      -- inconsistent)
     tidy_vars = mkVarEnv [ (tidy_var, (tidy_var, tidy_var_v))
                          | (var, var_v) <- varEnvElts vars
                          , let tidy_var   = lookup_var var
                                tidy_var_v = lookup_var var_v
+                         , isExportedId tidy_var
                          , isExportedId tidy_var_v
+                         , isDataConWorkId var || not (isImplicitId var)
                          ]
 
     tidy_scalarVars = mkVarSet [ lookup_var var 

compiler/nativeGen/PPC/CodeGen.hs

@@ -849,12 +849,7 @@ genCCall target dest_regs argsAndHints
       case platformOS (targetPlatform dflags) of
           OSLinux    -> genCCall' GCPLinux  target dest_regs argsAndHints
           OSDarwin   -> genCCall' GCPDarwin target dest_regs argsAndHints
-          OSSolaris2 -> panic "PPC.CodeGen.genCCall: not defined for this os"
-          OSMinGW32  -> panic "PPC.CodeGen.genCCall: not defined for this os"
-          OSFreeBSD  -> panic "PPC.CodeGen.genCCall: not defined for this os"
-          OSOpenBSD  -> panic "PPC.CodeGen.genCCall: not defined for this os"
-          OSNetBSD   -> panic "PPC.CodeGen.genCCall: not defined for this os"
-          OSUnknown  -> panic "PPC.CodeGen.genCCall: not defined for this os"
+          _ -> panic "PPC.CodeGen.genCCall: not defined for this os"
 
 data GenCCallPlatform = GCPLinux | GCPDarwin
 

compiler/nativeGen/PPC/Ppr.hs

@@ -6,22 +6,15 @@
 --
 -----------------------------------------------------------------------------
 
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 module PPC.Ppr (
-	pprNatCmmDecl,
-	pprBasicBlock,
-	pprSectionHeader,
-	pprData,
-	pprInstr,
-	pprSize,
-	pprImm,
-	pprDataItem,
+        pprNatCmmDecl,
+        pprBasicBlock,
+        pprSectionHeader,
+        pprData,
+        pprInstr,
+        pprSize,
+        pprImm,
+        pprDataItem,
 )
 
 where
@@ -40,7 +33,7 @@ import OldCmm
 
 import CLabel
 
-import Unique		( pprUnique, Uniquable(..) )
+import Unique                ( pprUnique, Uniquable(..) )
 import Platform
 import Pretty
 import FastString
@@ -209,23 +202,23 @@ pprReg platform r
 pprSize :: Size -> Doc
 pprSize x 
  = ptext (case x of
-		II8	-> sLit "b"
-	        II16	-> sLit "h"
-		II32	-> sLit "w"
-		FF32	-> sLit "fs"
-		FF64	-> sLit "fd"
-		_	-> panic "PPC.Ppr.pprSize: no match")
-		
-		
+                II8        -> sLit "b"
+                II16        -> sLit "h"
+                II32        -> sLit "w"
+                FF32        -> sLit "fs"
+                FF64        -> sLit "fd"
+                _        -> panic "PPC.Ppr.pprSize: no match")
+                
+                
 pprCond :: Cond -> Doc
 pprCond c 
  = ptext (case c of {
-		ALWAYS  -> sLit "";
-		EQQ	-> sLit "eq";	NE    -> sLit "ne";
-		LTT     -> sLit "lt";  GE    -> sLit "ge";
-		GTT     -> sLit "gt";  LE    -> sLit "le";
-		LU      -> sLit "lt";  GEU   -> sLit "ge";
-		GU      -> sLit "gt";  LEU   -> sLit "le"; })
+                ALWAYS  -> sLit "";
+                EQQ        -> sLit "eq";        NE    -> sLit "ne";
+                LTT     -> sLit "lt";  GE    -> sLit "ge";
+                GTT     -> sLit "gt";  LE    -> sLit "le";
+                LU      -> sLit "lt";  GEU   -> sLit "ge";
+                GU      -> sLit "gt";  LEU   -> sLit "le"; })
 
 
 pprImm :: Platform -> Imm -> Doc
@@ -294,21 +287,21 @@ pprDataItem :: Platform -> CmmLit -> Doc
 pprDataItem platform lit
   = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
     where
-	imm = litToImm lit
+        imm = litToImm lit
 
-	ppr_item II8   _ = [ptext (sLit "\t.byte\t") <> pprImm platform imm]
+        ppr_item II8   _ = [ptext (sLit "\t.byte\t") <> pprImm platform imm]
 
-	ppr_item II32  _ = [ptext (sLit "\t.long\t") <> pprImm platform imm]
+        ppr_item II32  _ = [ptext (sLit "\t.long\t") <> pprImm platform imm]
 
-	ppr_item FF32 (CmmFloat r _)
+        ppr_item FF32 (CmmFloat r _)
            = let bs = floatToBytes (fromRational r)
              in  map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs
 
-    	ppr_item FF64 (CmmFloat r _)
+        ppr_item FF64 (CmmFloat r _)
            = let bs = doubleToBytes (fromRational r)
              in  map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs
 
-	ppr_item II16 _	= [ptext (sLit "\t.short\t") <> pprImm platform imm]
+        ppr_item II16 _        = [ptext (sLit "\t.short\t") <> pprImm platform imm]
 
         ppr_item II64 (CmmInt x _)  =
                 [ptext (sLit "\t.long\t")
@@ -317,8 +310,8 @@ pprDataItem platform lit
                  ptext (sLit "\t.long\t")
                     <> int (fromIntegral (fromIntegral x :: Word32))]
 
-	ppr_item _ _
-		= panic "PPC.Ppr.pprDataItem: no match"
+        ppr_item _ _
+                = panic "PPC.Ppr.pprDataItem: no match"
 
 
 pprInstr :: Platform -> Instr -> Doc
@@ -342,145 +335,145 @@ pprInstr _ (LDATA _ _)
 {-
 pprInstr _ (SPILL reg slot)
    = hcat [
-   	ptext (sLit "\tSPILL"),
-	char '\t',
-	pprReg platform reg,
-	comma,
-	ptext (sLit "SLOT") <> parens (int slot)]
+           ptext (sLit "\tSPILL"),
+        char '\t',
+        pprReg platform reg,
+        comma,
+        ptext (sLit "SLOT") <> parens (int slot)]
 
 pprInstr _ (RELOAD slot reg)
    = hcat [
-   	ptext (sLit "\tRELOAD"),
-	char '\t',
-	ptext (sLit "SLOT") <> parens (int slot),
-	comma,
-	pprReg platform reg]
+           ptext (sLit "\tRELOAD"),
+        char '\t',
+        ptext (sLit "SLOT") <> parens (int slot),
+        comma,
+        pprReg platform reg]
 -}
 
 pprInstr platform (LD sz reg addr) = hcat [
-	char '\t',
-	ptext (sLit "l"),
-	ptext (case sz of
-	    II8  -> sLit "bz"
-	    II16 -> sLit "hz"
-	    II32 -> sLit "wz"
-	    FF32 -> sLit "fs"
-	    FF64 -> sLit "fd"
-	    _	 -> panic "PPC.Ppr.pprInstr: no match"
-	    ),
+        char '\t',
+        ptext (sLit "l"),
+        ptext (case sz of
+            II8  -> sLit "bz"
+            II16 -> sLit "hz"
+            II32 -> sLit "wz"
+            FF32 -> sLit "fs"
+            FF64 -> sLit "fd"
+            _         -> panic "PPC.Ppr.pprInstr: no match"
+            ),
         case addr of AddrRegImm _ _ -> empty
                      AddrRegReg _ _ -> char 'x',
-	char '\t',
-	pprReg platform reg,
-	ptext (sLit ", "),
-	pprAddr platform addr
+        char '\t',
+        pprReg platform reg,
+        ptext (sLit ", "),
+        pprAddr platform addr
     ]
 pprInstr platform (LA sz reg addr) = hcat [
-	char '\t',
-	ptext (sLit "l"),
-	ptext (case sz of
-	    II8  -> sLit "ba"
-	    II16 -> sLit "ha"
-	    II32 -> sLit "wa"
-	    FF32 -> sLit "fs"
-	    FF64 -> sLit "fd"
-	    _	 -> panic "PPC.Ppr.pprInstr: no match"
-	    ),
+        char '\t',
+        ptext (sLit "l"),
+        ptext (case sz of
+            II8  -> sLit "ba"
+            II16 -> sLit "ha"
+            II32 -> sLit "wa"
+            FF32 -> sLit "fs"
+            FF64 -> sLit "fd"
+            _         -> panic "PPC.Ppr.pprInstr: no match"
+            ),
         case addr of AddrRegImm _ _ -> empty
                      AddrRegReg _ _ -> char 'x',
-	char '\t',
-	pprReg platform reg,
-	ptext (sLit ", "),
-	pprAddr platform addr
+        char '\t',
+        pprReg platform reg,
+        ptext (sLit ", "),
+        pprAddr platform addr
     ]
 pprInstr platform (ST sz reg addr) = hcat [
-	char '\t',
-	ptext (sLit "st"),
-	pprSize sz,
+        char '\t',
+        ptext (sLit "st"),
+        pprSize sz,
         case addr of AddrRegImm _ _ -> empty
                      AddrRegReg _ _ -> char 'x',
-	char '\t',
-	pprReg platform reg,
-	ptext (sLit ", "),
-	pprAddr platform addr
+        char '\t',
+        pprReg platform reg,
+        ptext (sLit ", "),
+        pprAddr platform addr
     ]
 pprInstr platform (STU sz reg addr) = hcat [
-	char '\t',
-	ptext (sLit "st"),
-	pprSize sz,
-	ptext (sLit "u\t"),
+        char '\t',
+        ptext (sLit "st"),
+        pprSize sz,
+        ptext (sLit "u\t"),
         case addr of AddrRegImm _ _ -> empty
                      AddrRegReg _ _ -> char 'x',
-	pprReg platform reg,
-	ptext (sLit ", "),
-	pprAddr platform addr
+        pprReg platform reg,
+        ptext (sLit ", "),
+        pprAddr platform addr
     ]
 pprInstr platform (LIS reg imm) = hcat [
-	char '\t',
-	ptext (sLit "lis"),
-	char '\t',
-	pprReg platform reg,
-	ptext (sLit ", "),
-	pprImm platform imm
+        char '\t',
+        ptext (sLit "lis"),
+        char '\t',
+        pprReg platform reg,
+        ptext (sLit ", "),
+        pprImm platform imm
     ]
 pprInstr platform (LI reg imm) = hcat [
-	char '\t',
-	ptext (sLit "li"),
-	char '\t',
-	pprReg platform reg,
-	ptext (sLit ", "),
-	pprImm platform imm
+        char '\t',
+        ptext (sLit "li"),
+        char '\t',
+        pprReg platform reg,
+        ptext (sLit ", "),
+        pprImm platform imm
     ]
 pprInstr platform (MR reg1 reg2) 
     | reg1 == reg2 = empty
     | otherwise = hcat [
-	char '\t',
-	case targetClassOfReg platform reg1 of
-	    RcInteger -> ptext (sLit "mr")
-	    _ -> ptext (sLit "fmr"),
-	char '\t',
-	pprReg platform reg1,
-	ptext (sLit ", "),
-	pprReg platform reg2
+        char '\t',
+        case targetClassOfReg platform reg1 of
+            RcInteger -> ptext (sLit "mr")
+            _ -> ptext (sLit "fmr"),
+        char '\t',
+        pprReg platform reg1,
+        ptext (sLit ", "),
+        pprReg platform reg2
     ]
 pprInstr platform (CMP sz reg ri) = hcat [
-	char '\t',
-	op,
-	char '\t',
-	pprReg platform reg,
-	ptext (sLit ", "),
-	pprRI platform ri
+        char '\t',
+        op,
+        char '\t',
+        pprReg platform reg,
+        ptext (sLit ", "),
+        pprRI platform ri
     ]
     where
-	op = hcat [
-		ptext (sLit "cmp"),
-		pprSize sz,
-		case ri of
-		    RIReg _ -> empty
-		    RIImm _ -> char 'i'
-	    ]
+        op = hcat [
+                ptext (sLit "cmp"),
+                pprSize sz,
+                case ri of
+                    RIReg _ -> empty
+                    RIImm _ -> char 'i'
+            ]
 pprInstr platform (CMPL sz reg ri) = hcat [
-	char '\t',
-	op,
-	char '\t',
-	pprReg platform reg,
-	ptext (sLit ", "),
-	pprRI platform ri
+        char '\t',
+        op,
+        char '\t',
+        pprReg platform reg,
+        ptext (sLit ", "),
+        pprRI platform ri
     ]
     where
-	op = hcat [
-		ptext (sLit "cmpl"),
-		pprSize sz,
-		case ri of
-		    RIReg _ -> empty
-		    RIImm _ -> char 'i'
-	    ]
+        op = hcat [
+                ptext (sLit "cmpl"),
+                pprSize sz,
+                case ri of
+                    RIReg _ -> empty
+                    RIImm _ -> char 'i'
+            ]
 pprInstr platform (BCC cond blockid) = hcat [
-	char '\t',
-	ptext (sLit "b"),
-	pprCond cond,
-	char '\t',
-	pprCLabel_asm platform lbl
+        char '\t',
+        ptext (sLit "b"),
+        pprCond cond,
+        char '\t',
+        pprCLabel_asm platform lbl
     ]
     where lbl = mkAsmTempLabel (getUnique blockid)
 
@@ -498,40 +491,40 @@ pprInstr platform (BCCFAR cond blockid) = vcat [
     where lbl = mkAsmTempLabel (getUnique blockid)
 
 pprInstr platform (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
-	char '\t',
-	ptext (sLit "b"),
-	char '\t',
-	pprCLabel_asm platform lbl
+        char '\t',
+        ptext (sLit "b"),
+        char '\t',
+        pprCLabel_asm platform lbl
     ]
 
 pprInstr platform (MTCTR reg) = hcat [
-	char '\t',
-	ptext (sLit "mtctr"),
-	char '\t',
-	pprReg platform reg
+        char '\t',
+        ptext (sLit "mtctr"),
+        char '\t',
+        pprReg platform reg
     ]
 pprInstr _ (BCTR _ _) = hcat [
-	char '\t',
-	ptext (sLit "bctr")
+        char '\t',
+        ptext (sLit "bctr")
     ]
 pprInstr platform (BL lbl _) = hcat [
-	ptext (sLit "\tbl\t"),
+        ptext (sLit "\tbl\t"),
         pprCLabel_asm platform lbl
     ]
 pprInstr _ (BCTRL _) = hcat [
-	char '\t',
-	ptext (sLit "bctrl")
+        char '\t',
+        ptext (sLit "bctrl")
     ]
 pprInstr platform (ADD reg1 reg2 ri) = pprLogic platform (sLit "add") reg1 reg2 ri
 pprInstr platform (ADDIS reg1 reg2 imm) = hcat [
-	char '\t',
-	ptext (sLit "addis"),
-	char '\t',
-	pprReg platform reg1,
-	ptext (sLit ", "),
-	pprReg platform reg2,
-	ptext (sLit ", "),
-	pprImm platform imm
+        char '\t',
+        ptext (sLit "addis"),
+        char '\t',
+        pprReg platform reg1,
+        ptext (sLit ", "),
+        pprReg platform reg2,
+        ptext (sLit ", "),
+        pprImm platform imm
     ]
 
 pprInstr platform (ADDC reg1 reg2 reg3) = pprLogic platform (sLit "addc") reg1 reg2 (RIReg reg3)
@@ -552,17 +545,17 @@ pprInstr platform (MULLW_MayOflo reg1 reg2 reg3) = vcat [
                                           ptext (sLit "2, 31, 31") ]
     ]
 
-    	-- for some reason, "andi" doesn't exist.
-	-- we'll use "andi." instead.
+            -- for some reason, "andi" doesn't exist.
+        -- we'll use "andi." instead.
 pprInstr platform (AND reg1 reg2 (RIImm imm)) = hcat [
-	char '\t',
-	ptext (sLit "andi."),
-	char '\t',
-	pprReg platform reg1,
-	ptext (sLit ", "),
-	pprReg platform reg2,
-	ptext (sLit ", "),
-	pprImm platform imm
+        char '\t',
+        ptext (sLit "andi."),
+        char '\t',
+        pprReg platform reg1,
+        ptext (sLit ", "),
+        pprReg platform reg2,
+        ptext (sLit ", "),
+        pprImm platform imm
     ]
 pprInstr platform (AND reg1 reg2 ri) = pprLogic platform (sLit "and") reg1 reg2 ri
 
@@ -570,31 +563,38 @@ pprInstr platform (OR reg1 reg2 ri) = pprLogic platform (sLit "or") reg1 reg2 ri
 pprInstr platform (XOR reg1 reg2 ri) = pprLogic platform (sLit "xor") reg1 reg2 ri
 
 pprInstr platform (XORIS reg1 reg2 imm) = hcat [
-	char '\t',
-	ptext (sLit "xoris"),
-	char '\t',
-	pprReg platform reg1,
-	ptext (sLit ", "),
-	pprReg platform reg2,
-	ptext (sLit ", "),
-	pprImm platform imm
+        char '\t',
+        ptext (sLit "xoris"),
+        char '\t',
+        pprReg platform reg1,
+        ptext (sLit ", "),
+        pprReg platform reg2,
+        ptext (sLit ", "),
+        pprImm platform imm
     ]
 
 pprInstr platform (EXTS sz reg1 reg2) = hcat [
-	char '\t',
-	ptext (sLit "exts"),
-	pprSize sz,
-	char '\t',
-	pprReg platform reg1,
-	ptext (sLit ", "),
-	pprReg platform reg2
+        char '\t',
+        ptext (sLit "exts"),
+        pprSize sz,
+        char '\t',
+        pprReg platform reg1,
+        ptext (sLit ", "),
+        pprReg platform reg2
     ]
 
 pprInstr platform (NEG reg1 reg2) = pprUnary platform (sLit "neg") reg1 reg2
 pprInstr platform (NOT reg1 reg2) = pprUnary platform (sLit "not") reg1 reg2
 
 pprInstr platform (SLW reg1 reg2 ri) = pprLogic platform (sLit "slw") reg1 reg2 (limitShiftRI ri)
+
+pprInstr platform (SRW reg1 reg2 (RIImm (ImmInt i))) | i > 31 || i < 0 =
+    -- 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.
+    pprInstr platform (XOR reg1 reg2 (RIReg reg2))
 pprInstr platform (SRW reg1 reg2 ri) = pprLogic platform (sLit "srw") reg1 reg2 (limitShiftRI ri)
+
 pprInstr platform (SRAW reg1 reg2 ri) = pprLogic platform (sLit "sraw") reg1 reg2 (limitShiftRI ri)
 pprInstr platform (RLWINM reg1 reg2 sh mb me) = hcat [
         ptext (sLit "\trlwinm\t"),
@@ -616,14 +616,14 @@ pprInstr platform (FDIV sz reg1 reg2 reg3) = pprBinaryF platform (sLit "fdiv") s
 pprInstr platform (FNEG reg1 reg2) = pprUnary platform (sLit "fneg") reg1 reg2
 
 pprInstr platform (FCMP reg1 reg2) = hcat [
-	char '\t',
-	ptext (sLit "fcmpu\tcr0, "),
-	    -- Note: we're using fcmpu, not fcmpo
-	    -- The difference is with fcmpo, compare with NaN is an invalid operation.
-	    -- We don't handle invalid fp ops, so we don't care
-	pprReg platform reg1,
-	ptext (sLit ", "),
-	pprReg platform reg2
+        char '\t',
+        ptext (sLit "fcmpu\tcr0, "),
+            -- Note: we're using fcmpu, not fcmpo
+            -- The difference is with fcmpo, compare with NaN is an invalid operation.
+            -- We don't handle invalid fp ops, so we don't care
+        pprReg platform reg1,
+        ptext (sLit ", "),
+        pprReg platform reg2
     ]
 
 pprInstr platform (FCTIWZ reg1 reg2) = pprUnary platform (sLit "fctiwz") reg1 reg2
@@ -639,17 +639,17 @@ pprInstr _ (CRNOR dst src1 src2) = hcat [
     ]
 
 pprInstr platform (MFCR reg) = hcat [
-	char '\t',
-	ptext (sLit "mfcr"),
-	char '\t',
-	pprReg platform reg
+        char '\t',
+        ptext (sLit "mfcr"),
+        char '\t',
+        pprReg platform reg
     ]
 
 pprInstr platform (MFLR reg) = hcat [
-	char '\t',
-	ptext (sLit "mflr"),
-	char '\t',
-	pprReg platform reg
+        char '\t',
+        ptext (sLit "mflr"),
+        char '\t',
+        pprReg platform reg
     ]
 
 pprInstr platform (FETCHPC reg) = vcat [
@@ -664,42 +664,42 @@ pprInstr _ LWSYNC = ptext (sLit "\tlwsync")
 
 pprLogic :: Platform -> LitString -> Reg -> Reg -> RI -> Doc
 pprLogic platform op reg1 reg2 ri = hcat [
-	char '\t',
-	ptext op,
-	case ri of
-	    RIReg _ -> empty
-	    RIImm _ -> char 'i',
-	char '\t',
-	pprReg platform reg1,
-	ptext (sLit ", "),
-	pprReg platform reg2,
-	ptext (sLit ", "),
-	pprRI platform ri
+        char '\t',
+        ptext op,
+        case ri of
+            RIReg _ -> empty
+            RIImm _ -> char 'i',
+        char '\t',
+        pprReg platform reg1,
+        ptext (sLit ", "),
+        pprReg platform reg2,
+        ptext (sLit ", "),
+        pprRI platform ri
     ]
 
 
 pprUnary :: Platform -> LitString -> Reg -> Reg -> Doc
 pprUnary platform op reg1 reg2 = hcat [
-	char '\t',
-	ptext op,
-	char '\t',
-	pprReg platform reg1,
-	ptext (sLit ", "),
-	pprReg platform reg2
+        char '\t',
+        ptext op,
+        char '\t',
+        pprReg platform reg1,
+        ptext (sLit ", "),
+        pprReg platform reg2
     ]
     
     
 pprBinaryF :: Platform -> LitString -> Size -> Reg -> Reg -> Reg -> Doc
 pprBinaryF platform op sz reg1 reg2 reg3 = hcat [
-	char '\t',
-	ptext op,
-	pprFSize sz,
-	char '\t',
-	pprReg platform reg1,
-	ptext (sLit ", "),
-	pprReg platform reg2,
-	ptext (sLit ", "),
-	pprReg platform reg3
+        char '\t',
+        ptext op,
+        pprFSize sz,
+        char '\t',
+        pprReg platform reg1,
+        ptext (sLit ", "),
+        pprReg platform reg2,
+        ptext (sLit ", "),
+        pprReg platform reg3
     ]
     
 pprRI :: Platform -> RI -> Doc
@@ -708,13 +708,13 @@ pprRI platform (RIImm r) = pprImm platform r
 
 
 pprFSize :: Size -> Doc
-pprFSize FF64	= empty
-pprFSize FF32	= char 's'
-pprFSize _	= panic "PPC.Ppr.pprFSize: no match"
+pprFSize FF64     = empty
+pprFSize FF32     = char 's'
+pprFSize _        = panic "PPC.Ppr.pprFSize: no match"
 
-    -- limit immediate argument for shift instruction to range 0..32
-    -- (yes, the maximum is really 32, not 31)
+    -- limit immediate argument for shift instruction to range 0..31
 limitShiftRI :: RI -> RI
-limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32)
+limitShiftRI (RIImm (ImmInt i)) | i > 31 || i < 0 =
+  panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed."
 limitShiftRI x = x
 

compiler/nativeGen/X86/CodeGen.hs

@@ -1744,9 +1744,11 @@ genCCall32 target dest_regs args =
                                                        (ImmInt 0)
                              sz = floatSize w
                          in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),
+                                   DELTA (delta0 - b),
                                    GST sz fake0 tmp_amode,
                                    MOV sz (OpAddr tmp_amode) (OpReg r_dest),
-                                   ADD II32 (OpImm (ImmInt b)) (OpReg esp)]
+                                   ADD II32 (OpImm (ImmInt b)) (OpReg esp),
+                                   DELTA delta0]
                     else unitOL (GMOV fake0 r_dest)
               | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),
                                         MOV II32 (OpReg edx) (OpReg r_dest_hi)]

compiler/prelude/PrelNames.lhs

@@ -253,12 +253,16 @@ basicKnownKeyNames
 
         -- Integer
         integerTyConName, mkIntegerName,
+        integerToWord64Name, integerToInt64Name,
         plusIntegerName, timesIntegerName, smallIntegerName,
         integerToWordName, integerToIntName, minusIntegerName,
         negateIntegerName, eqIntegerName, neqIntegerName,
         absIntegerName, signumIntegerName,
         leIntegerName, gtIntegerName, ltIntegerName, geIntegerName,
         compareIntegerName, quotRemIntegerName, divModIntegerName,
+        quotIntegerName, remIntegerName,
+        floatFromIntegerName, doubleFromIntegerName,
+        encodeFloatIntegerName, encodeDoubleIntegerName,
         gcdIntegerName, lcmIntegerName,
         andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
         shiftLIntegerName, shiftRIntegerName,
@@ -820,17 +824,23 @@ minusName         = methName gHC_NUM (fsLit "-") minusClassOpKey
 negateName        = methName gHC_NUM (fsLit "negate") negateClassOpKey
 
 integerTyConName, mkIntegerName,
+    integerToWord64Name, integerToInt64Name,
     plusIntegerName, timesIntegerName, smallIntegerName,
     integerToWordName, integerToIntName, minusIntegerName,
     negateIntegerName, eqIntegerName, neqIntegerName,
     absIntegerName, signumIntegerName,
     leIntegerName, gtIntegerName, ltIntegerName, geIntegerName,
     compareIntegerName, quotRemIntegerName, divModIntegerName,
+    quotIntegerName, remIntegerName,
+    floatFromIntegerName, doubleFromIntegerName,
+    encodeFloatIntegerName, encodeDoubleIntegerName,
     gcdIntegerName, lcmIntegerName,
     andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
     shiftLIntegerName, shiftRIntegerName :: Name
 integerTyConName      = tcQual  gHC_INTEGER_TYPE (fsLit "Integer")           integerTyConKey
 mkIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "mkInteger")         mkIntegerIdKey
+integerToWord64Name   = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64")   integerToWord64IdKey
+integerToInt64Name    = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64")    integerToInt64IdKey
 plusIntegerName       = varQual gHC_INTEGER_TYPE (fsLit "plusInteger")       plusIntegerIdKey
 timesIntegerName      = varQual gHC_INTEGER_TYPE (fsLit "timesInteger")      timesIntegerIdKey
 smallIntegerName      = varQual gHC_INTEGER_TYPE (fsLit "smallInteger")      smallIntegerIdKey
@@ -849,6 +859,12 @@ geIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "geInteger")         geI
 compareIntegerName    = varQual gHC_INTEGER_TYPE (fsLit "compareInteger")    compareIntegerIdKey
 quotRemIntegerName    = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger")    quotRemIntegerIdKey
 divModIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "divModInteger")     divModIntegerIdKey
+quotIntegerName       = varQual gHC_INTEGER_TYPE (fsLit "quotInteger")       quotIntegerIdKey
+remIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "remInteger")        remIntegerIdKey
+floatFromIntegerName  = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger")      floatFromIntegerIdKey
+doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger")     doubleFromIntegerIdKey
+encodeFloatIntegerName  = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger")  encodeFloatIntegerIdKey
+encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleInteger") encodeDoubleIntegerIdKey
 gcdIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger")        gcdIntegerIdKey
 lcmIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger")        lcmIntegerIdKey
 andIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "andInteger")        andIntegerIdKey
@@ -1437,11 +1453,15 @@ assertIdKey                   = mkPreludeMiscIdUnique 44
 runSTRepIdKey                 = mkPreludeMiscIdUnique 45
 
 mkIntegerIdKey, smallIntegerIdKey, integerToWordIdKey, integerToIntIdKey,
+    integerToWord64IdKey, integerToInt64IdKey,
     plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey,
     negateIntegerIdKey,
     eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey,
     leIntegerIdKey, gtIntegerIdKey, ltIntegerIdKey, geIntegerIdKey,
     compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey,
+    quotIntegerIdKey, remIntegerIdKey,
+    floatFromIntegerIdKey, doubleFromIntegerIdKey,
+    encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey,
     gcdIntegerIdKey, lcmIntegerIdKey,
     andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey,
     shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique
@@ -1449,29 +1469,37 @@ mkIntegerIdKey                = mkPreludeMiscIdUnique 60
 smallIntegerIdKey             = mkPreludeMiscIdUnique 61
 integerToWordIdKey            = mkPreludeMiscIdUnique 62
 integerToIntIdKey             = mkPreludeMiscIdUnique 63
-plusIntegerIdKey              = mkPreludeMiscIdUnique 64
-timesIntegerIdKey             = mkPreludeMiscIdUnique 65
-minusIntegerIdKey             = mkPreludeMiscIdUnique 66
-negateIntegerIdKey            = mkPreludeMiscIdUnique 67
-eqIntegerIdKey                = mkPreludeMiscIdUnique 68
-neqIntegerIdKey               = mkPreludeMiscIdUnique 69
-absIntegerIdKey               = mkPreludeMiscIdUnique 70
-signumIntegerIdKey            = mkPreludeMiscIdUnique 71
-leIntegerIdKey                = mkPreludeMiscIdUnique 72
-gtIntegerIdKey                = mkPreludeMiscIdUnique 73
-ltIntegerIdKey                = mkPreludeMiscIdUnique 74
-geIntegerIdKey                = mkPreludeMiscIdUnique 75
-compareIntegerIdKey           = mkPreludeMiscIdUnique 76
-quotRemIntegerIdKey           = mkPreludeMiscIdUnique 77
-divModIntegerIdKey            = mkPreludeMiscIdUnique 78
-gcdIntegerIdKey               = mkPreludeMiscIdUnique 79
-lcmIntegerIdKey               = mkPreludeMiscIdUnique 80
-andIntegerIdKey               = mkPreludeMiscIdUnique 81
-orIntegerIdKey                = mkPreludeMiscIdUnique 82
-xorIntegerIdKey               = mkPreludeMiscIdUnique 83
-complementIntegerIdKey        = mkPreludeMiscIdUnique 84
-shiftLIntegerIdKey            = mkPreludeMiscIdUnique 85
-shiftRIntegerIdKey            = mkPreludeMiscIdUnique 86
+integerToWord64IdKey          = mkPreludeMiscIdUnique 64
+integerToInt64IdKey           = mkPreludeMiscIdUnique 65
+plusIntegerIdKey              = mkPreludeMiscIdUnique 66
+timesIntegerIdKey             = mkPreludeMiscIdUnique 67
+minusIntegerIdKey             = mkPreludeMiscIdUnique 68
+negateIntegerIdKey            = mkPreludeMiscIdUnique 69
+eqIntegerIdKey                = mkPreludeMiscIdUnique 70
+neqIntegerIdKey               = mkPreludeMiscIdUnique 71
+absIntegerIdKey               = mkPreludeMiscIdUnique 72
+signumIntegerIdKey            = mkPreludeMiscIdUnique 73
+leIntegerIdKey                = mkPreludeMiscIdUnique 74
+gtIntegerIdKey                = mkPreludeMiscIdUnique 75
+ltIntegerIdKey                = mkPreludeMiscIdUnique 76
+geIntegerIdKey                = mkPreludeMiscIdUnique 77
+compareIntegerIdKey           = mkPreludeMiscIdUnique 78
+quotRemIntegerIdKey           = mkPreludeMiscIdUnique 79
+divModIntegerIdKey            = mkPreludeMiscIdUnique 80
+quotIntegerIdKey              = mkPreludeMiscIdUnique 81
+remIntegerIdKey               = mkPreludeMiscIdUnique 82
+floatFromIntegerIdKey         = mkPreludeMiscIdUnique 83
+doubleFromIntegerIdKey        = mkPreludeMiscIdUnique 84
+encodeFloatIntegerIdKey       = mkPreludeMiscIdUnique 85
+encodeDoubleIntegerIdKey      = mkPreludeMiscIdUnique 86
+gcdIntegerIdKey               = mkPreludeMiscIdUnique 87
+lcmIntegerIdKey               = mkPreludeMiscIdUnique 88
+andIntegerIdKey               = mkPreludeMiscIdUnique 89
+orIntegerIdKey                = mkPreludeMiscIdUnique 90
+xorIntegerIdKey               = mkPreludeMiscIdUnique 91
+complementIntegerIdKey        = mkPreludeMiscIdUnique 92
+shiftLIntegerIdKey            = mkPreludeMiscIdUnique 93
+shiftRIntegerIdKey            = mkPreludeMiscIdUnique 94
 
 rootMainKey, runMainKey :: Unique
 rootMainKey                   = mkPreludeMiscIdUnique 100

compiler/prelude/PrelRules.lhs

@@ -621,31 +621,44 @@ builtinRules
 
 builtinIntegerRules :: [CoreRule]
 builtinIntegerRules =
- [rule_convert        "integerToWord"     integerToWordName     mkWordLitWord,
-  rule_convert        "integerToInt"      integerToIntName      mkIntLitInt,
-  rule_binop          "plusInteger"       plusIntegerName       (+),
-  rule_binop          "timesInteger"      timesIntegerName      (*),
-  rule_binop          "minusInteger"      minusIntegerName      (-),
-  rule_unop           "negateInteger"     negateIntegerName     negate,
-  rule_binop_Bool     "eqInteger"         eqIntegerName         (==),
-  rule_binop_Bool     "neqInteger"        neqIntegerName        (/=),
-  rule_unop           "absInteger"        absIntegerName        abs,
-  rule_unop           "signumInteger"     signumIntegerName     signum,
-  rule_binop_Bool     "leInteger"         leIntegerName         (<=),
-  rule_binop_Bool     "gtInteger"         gtIntegerName         (>),
-  rule_binop_Bool     "ltInteger"         ltIntegerName         (<),
-  rule_binop_Bool     "geInteger"         geIntegerName         (>=),
-  rule_binop_Ordering "compareInteger"    compareIntegerName    compare,
-  rule_divop          "quotRemInteger"    quotRemIntegerName    quotRem,
-  rule_divop          "divModInteger"     divModIntegerName     divMod,
-  rule_binop          "gcdInteger"        gcdIntegerName        gcd,
-  rule_binop          "lcmInteger"        lcmIntegerName        lcm,
-  rule_binop          "andInteger"        andIntegerName        (.&.),
-  rule_binop          "orInteger"         orIntegerName         (.|.),
-  rule_binop          "xorInteger"        xorIntegerName        xor,
-  rule_unop           "complementInteger" complementIntegerName complement,
-  rule_Int_binop      "shiftLInteger"     shiftLIntegerName     shiftL,
-  rule_Int_binop      "shiftRInteger"     shiftRIntegerName     shiftR]
+ [-- TODO: smallInteger rule
+  -- TODO: wordToInteger rule
+  rule_convert        "integerToWord"       integerToWordName       mkWordLitWord,
+  rule_convert        "integerToInt"        integerToIntName        mkIntLitInt,
+  rule_convert        "integerToWord64"     integerToWord64Name     mkWord64LitWord64,
+  -- TODO: word64ToInteger rule
+  rule_convert        "integerToInt64"      integerToInt64Name      mkInt64LitInt64,
+  -- TODO: int64ToInteger rule
+  rule_binop          "plusInteger"         plusIntegerName         (+),
+  rule_binop          "minusInteger"        minusIntegerName        (-),
+  rule_binop          "timesInteger"        timesIntegerName        (*),
+  rule_unop           "negateInteger"       negateIntegerName       negate,
+  rule_binop_Bool     "eqInteger"           eqIntegerName           (==),
+  rule_binop_Bool     "neqInteger"          neqIntegerName          (/=),
+  rule_unop           "absInteger"          absIntegerName          abs,
+  rule_unop           "signumInteger"       signumIntegerName       signum,
+  rule_binop_Bool     "leInteger"           leIntegerName           (<=),
+  rule_binop_Bool     "gtInteger"           gtIntegerName           (>),
+  rule_binop_Bool     "ltInteger"           ltIntegerName           (<),
+  rule_binop_Bool     "geInteger"           geIntegerName           (>=),
+  rule_binop_Ordering "compareInteger"      compareIntegerName      compare,
+  rule_divop_both     "divModInteger"       divModIntegerName       divMod,
+  rule_divop_both     "quotRemInteger"      quotRemIntegerName      quotRem,
+  rule_divop_one      "quotInteger"         quotIntegerName         quot,
+  rule_divop_one      "remInteger"          remIntegerName          rem,
+  rule_encodeFloat    "encodeFloatInteger"  encodeFloatIntegerName  mkFloatLitFloat,
+  rule_convert        "floatFromInteger"    floatFromIntegerName    mkFloatLitFloat,
+  rule_encodeFloat    "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
+  -- TODO: decodeDoubleInteger rule
+  rule_convert        "doubleFromInteger"   doubleFromIntegerName   mkDoubleLitDouble,
+  rule_binop          "gcdInteger"          gcdIntegerName          gcd,
+  rule_binop          "lcmInteger"          lcmIntegerName          lcm,
+  rule_binop          "andInteger"          andIntegerName          (.&.),
+  rule_binop          "orInteger"           orIntegerName           (.|.),
+  rule_binop          "xorInteger"          xorIntegerName          xor,
+  rule_unop           "complementInteger"   complementIntegerName   complement,
+  rule_Int_binop      "shiftLInteger"       shiftLIntegerName       shiftL,
+  rule_Int_binop      "shiftRInteger"       shiftRIntegerName       shiftR]
     where rule_convert str name convert
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
                            ru_try = match_Integer_convert convert }
@@ -655,9 +668,12 @@ builtinIntegerRules =
           rule_binop str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_binop op }
-          rule_divop str name op
+          rule_divop_both str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
-                           ru_try = match_Integer_divop op }
+                           ru_try = match_Integer_divop_both op }
+          rule_divop_one str name op
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
+                           ru_try = match_Integer_divop_one op }
           rule_Int_binop str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_Int_binop op }
@@ -667,6 +683,9 @@ builtinIntegerRules =
           rule_binop_Ordering str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_binop_Ordering op }
+          rule_encodeFloat str name op
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
+                           ru_try = match_Integer_Int_encodeFloat op }
 
 ---------------------------------------------------
 -- The rule is this:
@@ -737,7 +756,7 @@ match_Integer_convert :: Num a
                       -> Maybe (Expr CoreBndr)
 match_Integer_convert convert id_unf [xl]
   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
-  = Just (convert (fromIntegral x))
+  = Just (convert (fromInteger x))
 match_Integer_convert _ _ _ = Nothing
 
 match_Integer_unop :: (Integer -> Integer)
@@ -760,11 +779,11 @@ match_Integer_binop binop id_unf [xl,yl]
 match_Integer_binop _ _ _ = Nothing
 
 -- This helper is used for the quotRem and divMod functions
-match_Integer_divop :: (Integer -> Integer -> (Integer, Integer))
-                    -> IdUnfoldingFun
-                    -> [Expr CoreBndr]
-                    -> Maybe (Expr CoreBndr)
-match_Integer_divop divop id_unf [xl,yl]
+match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer))
+                         -> IdUnfoldingFun
+                         -> [Expr CoreBndr]
+                         -> Maybe (Expr CoreBndr)
+match_Integer_divop_both divop id_unf [xl,yl]
   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
@@ -776,9 +795,20 @@ match_Integer_divop divop id_unf [xl,yl]
                                Type integerTy,
                                Lit (LitInteger r i),
                                Lit (LitInteger s i)]
-      _ -> panic "match_Integer_divop: mkIntegerId has the wrong type"
+      _ -> panic "match_Integer_divop_both: mkIntegerId has the wrong type"
+match_Integer_divop_both _ _ _ = Nothing
 
-match_Integer_divop _ _ _ = Nothing
+-- This helper is used for the quotRem and divMod functions
+match_Integer_divop_one :: (Integer -> Integer -> Integer)
+                        -> IdUnfoldingFun
+                        -> [Expr CoreBndr]
+                        -> Maybe (Expr CoreBndr)
+match_Integer_divop_one divop id_unf [xl,yl]
+  | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+  , y /= 0
+  = Just (Lit (LitInteger (x `divop` y) i))
+match_Integer_divop_one _ _ _ = Nothing
 
 match_Integer_Int_binop :: (Integer -> Int -> Integer)
                         -> IdUnfoldingFun
@@ -812,4 +842,15 @@ match_Integer_binop_Ordering binop id_unf [xl, yl]
              EQ -> eqVal
              GT -> gtVal
 match_Integer_binop_Ordering _ _ _ = Nothing
+
+match_Integer_Int_encodeFloat :: RealFloat a
+                              => (a -> Expr CoreBndr)
+                              -> IdUnfoldingFun
+                              -> [Expr CoreBndr]
+                              -> Maybe (Expr CoreBndr)
+match_Integer_Int_encodeFloat mkLit id_unf [xl,yl]
+  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
+  , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
+  = Just (mkLit $ encodeFloat x (fromInteger y))
+match_Integer_Int_encodeFloat _ _ _ = Nothing
 \end{code}

compiler/prelude/PrimOp.lhs

@@ -12,7 +12,8 @@ module PrimOp (
         tagToEnumKey,
 
         primOpOutOfLine, primOpCodeSize,
-        primOpOkForSpeculation, primOpIsCheap,
+        primOpOkForSpeculation, primOpOkForSideEffects,
+        primOpIsCheap,
 
         getPrimOpResultInfo,  PrimOpResultInfo(..),
 
@@ -285,7 +286,7 @@ code generator will fall over if they aren't satisfied.
 
 %************************************************************************
 %*                                                                      *
-\subsubsection[PrimOp-ool]{Which PrimOps are out-of-line}
+            Which PrimOps are out-of-line
 %*                                                                      *
 %************************************************************************
 
@@ -299,36 +300,123 @@ primOpOutOfLine :: PrimOp -> Bool
 \end{code}
 
 
-primOpOkForSpeculation
-~~~~~~~~~~~~~~~~~~~~~~
-Sometimes we may choose to execute a PrimOp even though it isn't
-certain that its result will be required; ie execute them
-``speculatively''.  The same thing as ``cheap eagerness.'' Usually
-this is OK, because PrimOps are usually cheap, but it isn't OK for
-(a)~expensive PrimOps and (b)~PrimOps which can fail.
+%************************************************************************
+%*                                                                      *
+            Failure and side effects
+%*                                                                      *
+%************************************************************************
 
-PrimOps that have side effects also should not be executed speculatively.
+Note [PrimOp can_fail and has_side_effects]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Both can_fail and has_side_effects mean that the primop has
+some effect that is not captured entirely by its result value.
+
+   ----------  has_side_effects ---------------------
+   Has some imperative side effect, perhaps on the world (I/O),
+   or perhaps on some mutable data structure (writeIORef).
+   Generally speaking all such primops have a type like
+      State -> input -> (State, output)
+   so the state token guarantees ordering, and also ensures
+   that the primop is executed even if 'output' is discarded.
+
+   ----------  can_fail ----------------------------
+   Can fail with a seg-fault or divide-by-zero error on some elements
+   of its input domain.  Main examples:
+      division (fails on zero demoninator
+      array indexing (fails if the index is out of bounds)
+   However (ASSUMPTION), these can_fail primops are ALWAYS surrounded
+   with a test that checks for the bad cases.  
+
+Consequences:
+
+* You can discard a can_fail primop, or float it _inwards_.
+  But you cannot float it _outwards_, lest you escape the
+  dynamic scope of the test.  Example:
+      case d ># 0# of
+        True  -> case x /# d of r -> r +# 1
+        False -> 0
+  Here we must not float the case outwards to give
+      case x/# d of r ->
+      case d ># 0# of
+        True  -> r +# 1
+        False -> 0
+
+* I believe that exactly the same rules apply to a has_side_effects
+  primop; you can discard it (remember, the state token will keep
+  it alive if necessary), or float it in, but not float it out.
+
+  Example of the latter
+       if blah then let! s1 = writeMutVar s0 v True in s1
+               else s0
+  Notice that s0 is mentioned in both branches of the 'if', but 
+  only one of these two will actually be consumed.  But if we
+  float out to
+      let! s1 = writeMutVar s0 v True
+      in if blah then s1 else s0
+  the writeMutVar will be performed in both branches, which is
+  utterly wrong.
+
+* You cannot duplicate a has_side_effect primop.  You might wonder
+  how this can occur given the state token threading, but just look
+  at Control.Monad.ST.Lazy.Imp.strictToLazy!  We get something like
+  this
+        p = case readMutVar# s v of
+              (# s', r #) -> (S# s', r)
+        s' = case p of (s', r) -> s'
+        r  = case p of (s', r) -> r
+
+  (All these bindings are boxed.)  If we inline p at its two call
+  sites, we get a catastrophe: because the read is performed once when
+  s' is demanded, and once when 'r' is demanded, which may be much 
+  later.  Utterly wrong.  Trac #3207 is real example of this happening.
+
+  However, it's fine to duplicate a can_fail primop.  That is
+  the difference between can_fail and has_side_effects.
+
+            can_fail     has_side_effects
+Discard        YES           YES
+Float in       YES           YES
+Float out      NO            NO
+Duplicate      YES           NO
+
+How do we achieve these effects?
+
+Note [primOpOkForSpeculation]
+  * The "no-float-out" thing is achieved by ensuring that we never
+    let-bind a can_fail or has_side_effects primop.  The RHS of a
+    let-binding (which can float in and out freely) satisfies
+    exprOkForSpeculation.  And exprOkForSpeculation is false of
+    can_fail and no_side_effect.
+
+  * So can_fail and no_side_effect primops will appear only as the
+    scrutinees of cases, and that's why the FloatIn pass is capable
+    of floating case bindings inwards.
+
+  * The no-duplicate thing is done via primOpIsCheap, by making
+    has_side_effects things (very very very) not-cheap!
 
-Ok-for-speculation also means that it's ok *not* to execute the
-primop. For example
-        case op a b of
-          r -> 3
-Here the result is not used, so we can discard the primop.  Anything
-that has side effects mustn't be dicarded in this way, of course!
 
-See also @primOpIsCheap@ (below).
+\begin{code}
+primOpHasSideEffects :: PrimOp -> Bool
+#include "primop-has-side-effects.hs-incl"
 
+primOpCanFail :: PrimOp -> Bool
+#include "primop-can-fail.hs-incl"
 
-\begin{code}
 primOpOkForSpeculation :: PrimOp -> Bool
-        -- See comments with CoreUtils.exprOkForSpeculation
+  -- See Note [primOpOkForSpeculation and primOpOkForFloatOut]
+  -- See comments with CoreUtils.exprOkForSpeculation
 primOpOkForSpeculation op
   = not (primOpHasSideEffects op || primOpOutOfLine op || primOpCanFail op)
+
+primOpOkForSideEffects :: PrimOp -> Bool
+primOpOkForSideEffects op
+  = not (primOpHasSideEffects op)
 \end{code}
 
 
-primOpIsCheap
-~~~~~~~~~~~~~
+Note [primOpIsCheap]
+~~~~~~~~~~~~~~~~~~~~
 @primOpIsCheap@, as used in \tr{SimplUtils.lhs}.  For now (HACK
 WARNING), we just borrow some other predicates for a
 what-should-be-good-enough test.  "Cheap" means willing to call it more
@@ -356,6 +444,13 @@ primOpIsCheap op = primOpOkForSpeculation op
 -- even if primOpIsCheap sometimes says 'True'.
 \end{code}
 
+
+%************************************************************************
+%*                                                                      *
+               PrimOp code size
+%*                                                                      *
+%************************************************************************
+
 primOpCodeSize
 ~~~~~~~~~~~~~~
 Gives an indication of the code size of a primop, for the purposes of
@@ -374,50 +469,12 @@ primOpCodeSizeForeignCall :: Int
 primOpCodeSizeForeignCall = 4
 \end{code}
 
-\begin{code}
-primOpCanFail :: PrimOp -> Bool
-#include "primop-can-fail.hs-incl"
-\end{code}
-
-And some primops have side-effects and so, for example, must not be
-duplicated.
-
-This predicate means a little more than just "modifies the state of
-the world".  What it really means is "it cosumes the state on its
-input".  To see what this means, consider
-
- let
-     t = case readMutVar# v s0 of (# s1, x #) -> (S# s1, x)
-     y = case t of (s,x) -> x
- in
-     ... y ... y ...
-
-Now, this is part of an ST or IO thread, so we are guaranteed by
-construction that the program uses the state in a single-threaded way.
-Whenever the state resulting from the readMutVar# is demanded, the
-readMutVar# will be performed, and it will be ordered correctly with
-respect to other operations in the monad.
-
-But there's another way this could go wrong: GHC can inline t into y,
-and inline y.  Then although the original readMutVar# will still be
-correctly ordered with respect to the other operations, there will be
-one or more extra readMutVar#s performed later, possibly out-of-order.
-This really happened; see #3207.
-
-The property we need to capture about readMutVar# is that it consumes
-the State# value on its input.  We must retain the linearity of the
-State#.
-
-Our fix for this is to declare any primop that must be used linearly
-as having side-effects.  When primOpHasSideEffects is True,
-primOpOkForSpeculation will be False, and hence primOpIsCheap will
-also be False, and applications of the primop will never be
-duplicated.
 
-\begin{code}
-primOpHasSideEffects :: PrimOp -> Bool
-#include "primop-has-side-effects.hs-incl"
-\end{code}
+%************************************************************************
+%*                                                                      *
+               PrimOp types
+%*                                                                      *
+%************************************************************************
 
 \begin{code}
 primOpType :: PrimOp -> Type  -- you may want to use primOpSig instead

compiler/prelude/primops.txt.pp

@@ -41,12 +41,13 @@
 
 defaults
    has_side_effects = False
-   out_of_line      = False
+   out_of_line      = False   -- See Note Note [PrimOp can_fail and has_side_effects] in PrimOp
+   can_fail         = False   -- See Note Note [PrimOp can_fail and has_side_effects] in PrimOp
    commutable       = False
    code_size        = { primOpCodeSizeDefault }
-   can_fail         = False
    strictness       = { \ arity -> mkStrictSig (mkTopDmdType (replicate arity lazyDmd) TopRes) }
 
+
 -- Currently, documentation is produced using latex, so contents of
 -- description fields should be legal latex. Descriptions can contain
 -- matched pairs of embedded curly brackets.

compiler/rename/RnEnv.lhs

@@ -20,7 +20,7 @@ module RnEnv (
 	HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn,
 
 	lookupFixityRn, lookupTyFixityRn, 
-	lookupInstDeclBndr, lookupSubBndr, greRdrName,
+	lookupInstDeclBndr, lookupSubBndrOcc, greRdrName,
         lookupSubBndrGREs, lookupConstructorFields,
 	lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse,
 	lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
@@ -39,7 +39,7 @@ module RnEnv (
 	addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
 	warnUnusedMatches,
 	warnUnusedTopBinds, warnUnusedLocalBinds,
-	dataTcOccs, unknownNameErr, kindSigErr, polyKindsErr, perhapsForallMsg,
+	dataTcOccs, unknownNameErr, kindSigErr, dataKindsErr, perhapsForallMsg,
 
         HsDocContext(..), docOfHsDocContext
     ) where
@@ -241,10 +241,19 @@ lookupExactOcc name
   = do { env <- getGlobalRdrEnv
        ; let gres = lookupGRE_Name env name
        ; case gres of
-           []    -> return name
+           []    -> -- See Note [Splicing Exact names]
+                    do { lcl_env <- getLocalRdrEnv
+                       ; unless (name `inLocalRdrEnvScope` lcl_env)
+                                (addErr exact_nm_err)
+                       ; return name }
+   
            [gre] -> return (gre_name gre)
            _     -> pprPanic "lookupExactOcc" (ppr name $$ ppr gres) }
 
+  where
+    exact_nm_err = hang (ptext (sLit "The exact Name") <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))
+                      2 (ptext (sLit "Probable cause: you used a unique name (NameU) in Template Haskell but did not bind it"))
+
 -----------------------------------------------
 lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name
 -- This is called on the method name on the left-hand side of an 
@@ -267,7 +276,7 @@ lookupInstDeclBndr cls what rdr
 	       	-- In an instance decl you aren't allowed
       	     	-- to use a qualified name for the method
 		-- (Although it'd make perfect sense.)
-       ; lookupSubBndr (ParentIs cls) doc rdr }
+       ; lookupSubBndrOcc (ParentIs cls) doc rdr }
   where
     doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls)
 
@@ -304,11 +313,11 @@ lookupConstructorFields con_name
 -- unambiguous because there is only one field id 'fld' in scope.
 -- But currently it's rejected.
 
-lookupSubBndr :: Parent  -- NoParent   => just look it up as usual
-			 -- ParentIs p => use p to disambiguate
-              -> SDoc -> RdrName 
-              -> RnM Name
-lookupSubBndr parent doc rdr_name
+lookupSubBndrOcc :: Parent  -- NoParent   => just look it up as usual
+		    	    -- ParentIs p => use p to disambiguate
+                 -> SDoc -> RdrName 
+                 -> RnM Name
+lookupSubBndrOcc parent doc rdr_name
   | Just n <- isExact_maybe rdr_name   -- This happens in derived code
   = lookupExactOcc n
 
@@ -323,6 +332,7 @@ lookupSubBndr parent doc rdr_name
 		--     The latter does pickGREs, but we want to allow 'x'
 		--     even if only 'M.x' is in scope
 	    [gre] -> do { addUsedRdrName gre (used_rdr_name gre)
+                          -- Add a usage; this is an *occurrence* site
                         ; return (gre_name gre) }
 	    []    -> do { addErr (unknownSubordinateErr doc rdr_name)
 			; return (mkUnboundName rdr_name) }
@@ -383,6 +393,7 @@ positions for constructors, TyCons etc.  For example
     [d| data T = MkT Int |]
 when we splice in and Convert to HsSyn RdrName, we'll get
     data (Exact (system Name "T")) = (Exact (system Name "MkT")) ...
+These System names are generated by Convert.thRdrName
 
 But, constructors and the like need External Names, not System Names!
 So we do the following
@@ -393,7 +404,7 @@ So we do the following
 
  * When looking up an occurrence of an Exact name, done in
    RnEnv.lookupExactOcc, we find the Name with the right unique in the
-   GlobalRdrEnv, and use the on from the envt -- it will be an
+   GlobalRdrEnv, and use the one from the envt -- it will be an
    External Name in the case of the data type/constructor above.
 
  * Exact names are also use for purely local binders generated
@@ -405,6 +416,15 @@ So we do the following
    will find the Name is not in the GlobalRdrEnv, so we just use
    the Exact supplied Name.
 
+Note [Splicing Exact names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the splice $(do { x <- newName "x"; return (VarE x) })
+This will generate a (HsExpr RdrName) term that mentions the 
+Exact RdrName "x_56" (or whatever), but does not bind it.  So
+when looking such Exact names we want to check that it's in scope,
+otherwise the type checker will get confused.  To do this we need to
+keep track of all the Names in scope, and the LocalRdrEnv does just that;
+we consult it with RdrName.inLocalRdrEnvScope.
 
 Note [Usage for sub-bndrs]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -468,13 +488,13 @@ lookupPromotedOccRn rdr_name = do {
       Nothing -> err
       -- 2.b let's try every thing again -> 3
       Just demoted_rdr_name -> do {
-  ; poly_kinds <- xoptM Opt_PolyKinds
+  ; data_kinds <- xoptM Opt_DataKinds
     -- 3. lookup again
   ; opt_demoted_name <- lookupOccRn_maybe demoted_rdr_name ;
   ; case opt_demoted_name of
       -- 3.a. it was implicitly promoted, but confirm that we can promote
-      -- JPM: We could try to suggest turning on PolyKinds here
-      Just demoted_name -> if poly_kinds then return demoted_name else err
+      -- JPM: We could try to suggest turning on DataKinds here
+      Just demoted_name -> if data_kinds then return demoted_name else err
       -- 3.b. use rdr_name to have a correct error message
       Nothing -> err } } }
   where err = unboundName WL_Any rdr_name
@@ -669,6 +689,11 @@ lookupBindGroupOcc ctxt what rdr_name
        ; return (Right n') }  -- Maybe we should check the side conditions
        	 	      	      -- but it's a pain, and Exact things only show
 			      -- up when you know what you are doing
+
+  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+  = do { n' <- lookupOrig rdr_mod rdr_occ
+       ; return (Right n') }
+
   | otherwise
   = case ctxt of 
       HsBootCtxt       -> lookup_top		    
@@ -1193,7 +1218,7 @@ unknownNameSuggestErr where_look tried_rdr_name
       | tried_is_qual = []
       | not local_ok  = []
       | otherwise     = [ (mkRdrUnqual occ, nameSrcSpan name)
-                      	| name <- occEnvElts env
+                      	| name <- localRdrEnvElts env
                       	, let occ = nameOccName name
                       	, correct_name_space occ]
 
@@ -1412,10 +1437,10 @@ kindSigErr thing
   = hang (ptext (sLit "Illegal kind signature for") <+> quotes (ppr thing))
        2 (ptext (sLit "Perhaps you intended to use -XKindSignatures"))
 
-polyKindsErr :: Outputable a => a -> SDoc
-polyKindsErr thing
+dataKindsErr :: Outputable a => a -> SDoc
+dataKindsErr thing
   = hang (ptext (sLit "Illegal kind:") <+> quotes (ppr thing))
-       2 (ptext (sLit "Perhaps you intended to use -XPolyKinds"))
+       2 (ptext (sLit "Perhaps you intended to use -XDataKinds"))
 
 
 badQualBndrErr :: RdrName -> SDoc

compiler/rename/RnNames.lhs

@@ -60,12 +60,14 @@ and packages. Doing this without caching any trust information would be very
 slow as we would need to touch all packages and interface files a module depends
 on. To avoid this we make use of the property that if a modules Safe Haskell
 mode changes, this triggers a recompilation from that module in the dependcy
-graph. So we can just worry mostly about direct imports. There is one trust
-property that can change for a package though without recompliation being
-triggered, package trust. So we must check that all packages a module
-tranitively depends on to be trusted are still trusted when we are compiling
-this module (as due to recompilation avoidance some modules below may not be
-considered trusted any more without recompilation being triggered).
+graph. So we can just worry mostly about direct imports.
+
+There is one trust property that can change for a package though without
+recompliation being triggered: package trust. So we must check that all
+packages a module tranitively depends on to be trusted are still trusted when
+we are compiling this module (as due to recompilation avoidance some modules
+below may not be considered trusted any more without recompilation being
+triggered).
 
 We handle this by augmenting the existing transitive list of packages a module M
 depends on with a bool for each package that says if it must be trusted when the
@@ -110,7 +112,7 @@ haskell at all and simply imports B, should A inherit all the the trust
 requirements from B? Should A now also require that a package p is trusted since
 B required it?
 
-We currently say no but I saying yes also makes sense. The difference is, if a
+We currently say no but saying yes also makes sense. The difference is, if a
 module M that doesn't use Safe Haskell imports a module N that does, should all
 the trusted package requirements be dropped since M didn't declare that it cares
 about Safe Haskell (so -XSafe is more strongly associated with the module doing
@@ -404,7 +406,8 @@ extendGlobalRdrEnvRn avails new_fixities
               new_occs = map (nameOccName . gre_name) gres
               rdr_env_TH = transformGREs qual_gre new_occs rdr_env
               rdr_env_GHCi = delListFromOccEnv rdr_env new_occs
-              lcl_env1 = lcl_env { tcl_rdr = delListFromOccEnv (tcl_rdr lcl_env) new_occs }
+
+              lcl_env1 = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs }
               (rdr_env2, lcl_env2) | shadowP   = (rdr_env_TH,   lcl_env1)
                                    | isGHCi    = (rdr_env_GHCi, lcl_env1)
                                    | otherwise = (rdr_env,      lcl_env)
@@ -973,8 +976,7 @@ rnExports explicit_mod exports
         ; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod
         ; let final_avails = nubAvails avails    -- Combine families
 
-        ; traceRn (vcat [ text "rnExports: RdrEnv:" <+> ppr rdr_env
-                        , text "     Exports:" <+> ppr final_avails] )
+        ; traceRn (text "rnExports: Exports:" <+> ppr final_avails)
 
         ; return (tcg_env { tcg_exports    = final_avails,
                             tcg_rn_exports = case tcg_rn_exports tcg_env of

compiler/rename/RnPat.lhs

@@ -487,7 +487,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
     rn_fld pun_ok parent (HsRecField { hsRecFieldId = fld
                        	      	     , hsRecFieldArg = arg
                        	      	     , hsRecPun = pun })
-      = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndr parent doc) fld
+      = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc parent doc) fld
            ; arg' <- if pun 
                      then do { checkErr pun_ok (badPun fld)
                              ; return (L loc (mk_arg (mkRdrUnqual (nameOccName fld_nm)))) }

compiler/rename/RnSource.lhs

@@ -53,6 +53,7 @@ import Digraph		( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
 
 import Control.Monad
 import Maybes( orElse )
+import Data.List( partition )
 import Data.Maybe( isNothing )
 \end{code}
 
@@ -674,7 +675,7 @@ rnHsVectDecl (HsVectClassOut _)
   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
 rnHsVectDecl (HsVectInstIn instTy)
   = do { instTy' <- rnLHsInstType (text "In a VECTORISE pragma") instTy
-       ; return (HsVectInstIn instTy', emptyFVs)
+       ; return (HsVectInstIn instTy', extractHsTyNames instTy')
        }
 rnHsVectDecl (HsVectInstOut _)
   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
@@ -742,21 +743,28 @@ rnTyClDecls :: [Name] -> [[LTyClDecl RdrName]]
 rnTyClDecls extra_deps tycl_ds
   = do { ds_w_fvs <- mapM (wrapLocFstM (rnTyClDecl Nothing)) (concat tycl_ds)
        ; thisPkg  <- fmap thisPackage getDOpts
-       ; let add_boot_deps :: FreeVars -> FreeVars
+       ; let (fam_insts, non_fam_insts) = partition (isFamInstDecl . unLoc . fst) ds_w_fvs
+                  -- Ignore family instances when doing this dependency analysis
+                  -- because they don't have a binder
+
+             add_boot_deps :: FreeVars -> FreeVars
              -- See Note [Extra dependencies from .hs-boot files]
              add_boot_deps fvs | any (isInPackage thisPkg) (nameSetToList fvs)
                                = fvs `plusFV` mkFVs extra_deps
                                | otherwise
                                = fvs
 
-             ds_w_fvs' = map (\(ds, fvs) -> (ds, add_boot_deps fvs)) ds_w_fvs
+             ds_w_fvs' = map (\(ds, fvs) -> (ds, add_boot_deps fvs)) non_fam_insts
 
              sccs :: [SCC (LTyClDecl Name)]
              sccs = depAnalTyClDecls ds_w_fvs'
 
-             all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs'
+             all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs
+
 
-       ; return (map flattenSCC sccs, all_fvs) }
+       ; return (map fst fam_insts : map flattenSCC sccs, all_fvs) }
+            -- Just put the family-instance group first;
+            -- it is treated separately anyway
 
 
 rnTyClDecl :: Maybe Name  -- Just cls => this TyClDecl is nested 

compiler/rename/RnTypes.lhs

@@ -196,8 +196,8 @@ rnHsTyKi isType doc (HsFunTy ty1 ty2) = do
       else return (HsFunTy ty1' ty2')
 
 rnHsTyKi isType doc listTy@(HsListTy ty) = do
-    poly_kinds <- xoptM Opt_PolyKinds
-    unless (poly_kinds || isType) (addErr (polyKindsErr listTy))
+    data_kinds <- xoptM Opt_DataKinds
+    unless (data_kinds || isType) (addErr (dataKindsErr listTy))
     ty' <- rnLHsTyKi isType doc ty
     return (HsListTy ty')
 
@@ -216,8 +216,8 @@ rnHsTyKi isType doc (HsPArrTy ty) = ASSERT ( isType ) do
 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do
-    poly_kinds <- xoptM Opt_PolyKinds
-    unless (poly_kinds || isType) (addErr (polyKindsErr tupleTy))
+    data_kinds <- xoptM Opt_DataKinds
+    unless (data_kinds || isType) (addErr (dataKindsErr tupleTy))
     tys' <- mapM (rnLHsTyKi isType doc) tys
     return (HsTupleTy tup_con tys')
 
@@ -703,7 +703,7 @@ rnSplice (HsSplice n expr)
 	; gbl_rdr <- getGlobalRdrEnv
 	; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, 
 						    isLocalGRE gre]
-	      lcl_names = mkNameSet (occEnvElts lcl_rdr)
+	      lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
 
 	; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }