Commit b643fe08 authored by Ian Lynagh's avatar Ian Lynagh

Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

parents 9f611ccc 5bfd8933
......@@ -117,7 +117,7 @@ repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
repTopDs group
= do { let { tv_bndrs = hsSigTvBinders (hs_valds group)
; bndrs = tv_bndrs ++ hsGroupBinders group } ;
ss <- pprTrace "reptop" (ppr bndrs $$ ppr tv_bndrs) $ mkGenSyms bndrs ;
ss <- mkGenSyms bndrs ;
-- Bind all the names mainly to avoid repeated use of explicit strings.
-- Thus we get
......
......@@ -45,7 +45,7 @@ import Var
import TcRnMonad
import TcType
import TcMType
import TcHsSyn ( mkZonkTcTyVar )
import TcHsSyn ( zonkTcTypeToType, mkEmptyZonkEnv )
import TcUnify
import TcEnv
......@@ -1131,7 +1131,7 @@ zonkTerm = foldTermM (TermFoldM
zonkRttiType :: TcType -> TcM Type
-- Zonk the type, replacing any unbound Meta tyvars
-- by skolems, safely out of Meta-tyvar-land
zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta mkTyVarTy)
zonkRttiType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_meta)
where
zonk_unbound_meta tv
= ASSERT( isTcTyVar tv )
......
......@@ -63,7 +63,7 @@ import Control.Monad
%************************************************************************
%* *
loadSrcInterface, loadOrphanModules, loadHomeInterface
loadSrcInterface, loadOrphanModules, loadInterfaceForName
These three are called from TcM-land
%* *
......
......@@ -122,6 +122,11 @@ module GHC (
#endif
lookupName,
#ifdef GHCI
-- ** EXPERIMENTAL
setGHCiMonad,
#endif
-- * Abstract syntax elements
-- ** Packages
......@@ -1330,6 +1335,21 @@ isModuleTrusted :: GhcMonad m => Module -> m Bool
isModuleTrusted m = withSession $ \hsc_env ->
liftIO $ hscCheckSafe hsc_env m noSrcSpan
-- | EXPERIMENTAL: DO NOT USE.
--
-- Set the monad GHCi lifts user statements into.
--
-- Checks that a type (in string form) is an instance of the
-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is,
-- throws an error otherwise.
{-# WARNING setGHCiMonad "This is experimental! Don't use." #-}
setGHCiMonad :: GhcMonad m => String -> m ()
setGHCiMonad name = withSession $ \hsc_env -> do
ty <- liftIO $ hscIsGHCiMonad hsc_env name
modifySession $ \s ->
let ic = (hsc_IC s) { ic_monad = ty }
in s { hsc_IC = ic }
getHistorySpan :: GhcMonad m => History -> m SrcSpan
getHistorySpan h = withSession $ \hsc_env ->
return $ InteractiveEval.getHistorySpan hsc_env h
......
......@@ -62,6 +62,7 @@ module HscMain
, hscTcRnGetInfo
, hscCheckSafe
#ifdef GHCI
, hscIsGHCiMonad
, hscGetModuleInterface
, hscRnImportDecls
, hscTcRnLookupRdrName
......@@ -311,6 +312,11 @@ hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do
ioMsgMaybe' $ tcRnGetInfo hsc_env name
#ifdef GHCI
hscIsGHCiMonad :: HscEnv -> String -> IO Name
hscIsGHCiMonad hsc_env name =
let icntxt = hsc_IC hsc_env
in runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env icntxt name
hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
......
......@@ -136,7 +136,7 @@ import Annotations
import Class
import TyCon
import DataCon
import PrelNames ( gHC_PRIM )
import PrelNames ( gHC_PRIM, ioTyConName )
import Packages hiding ( Version(..) )
import DynFlags
import DriverPhases
......@@ -910,6 +910,9 @@ data InteractiveContext
-- ^ The 'DynFlags' used to evaluate interative expressions
-- and statements.
ic_monad :: Name,
-- ^ The monad that GHCi is executing in
ic_imports :: [InteractiveImport],
-- ^ The GHCi context is extended with these imports
--
......@@ -973,6 +976,8 @@ hscDeclsWithLocation) and save them in ic_sys_vars.
emptyInteractiveContext :: DynFlags -> InteractiveContext
emptyInteractiveContext dflags
= InteractiveContext { ic_dflags = dflags,
-- IO monad by default
ic_monad = ioTyConName,
ic_imports = [],
ic_rn_gbl_env = emptyGlobalRdrEnv,
ic_tythings = [],
......
......@@ -306,6 +306,9 @@ basicKnownKeyNames
, guardMName
, liftMName
, mzipName
-- GHCi Sandbox
, ghciIoClassName, ghciStepIoMName
]
genericTyConNames :: [Name]
......@@ -334,7 +337,7 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME
gHC_PRIM, gHC_TYPES, gHC_GENERICS,
gHC_MAGIC,
gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING,
gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST,
gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE,
gHC_CONC, gHC_IO, gHC_IO_Exception,
......@@ -353,6 +356,7 @@ gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes")
gHC_BASE = mkBaseModule (fsLit "GHC.Base")
gHC_ENUM = mkBaseModule (fsLit "GHC.Enum")
gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi")
gHC_SHOW = mkBaseModule (fsLit "GHC.Show")
gHC_READ = mkBaseModule (fsLit "GHC.Read")
gHC_NUM = mkBaseModule (fsLit "GHC.Num")
......@@ -971,6 +975,11 @@ datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey
constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey
selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey
-- GHCi things
ghciIoClassName, ghciStepIoMName :: Name
ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey
ghciStepIoMName = methName gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey
-- IO things
ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName,
failIOName :: Name
......@@ -1179,6 +1188,9 @@ selectorClassKey = mkPreludeClassUnique 41
singIClassNameKey, typeNatLeqClassNameKey :: Unique
singIClassNameKey = mkPreludeClassUnique 42
typeNatLeqClassNameKey = mkPreludeClassUnique 43
ghciIoClassKey :: Unique
ghciIoClassKey = mkPreludeClassUnique 44
\end{code}
%************************************************************************
......@@ -1647,6 +1659,10 @@ guardMIdKey = mkPreludeMiscIdUnique 194
liftMIdKey = mkPreludeMiscIdUnique 195
mzipIdKey = mkPreludeMiscIdUnique 196
-- GHCi
ghciStepIoMClassOpKey :: Unique
ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197
---------------- Template Haskell -------------------
-- USES IdUniques 200-499
......
......@@ -19,7 +19,7 @@ module RnEnv (
lookupTypeOccRn, lookupKindOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn,
HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
lookupFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName,
......@@ -238,7 +238,14 @@ lookupExactOcc name
= return name
| otherwise
= do { env <- getGlobalRdrEnv
; let gres = lookupGRE_Name env name
; let -- See Note [Splicing Exact names]
main_occ = nameOccName name
demoted_occs = case demoteOccName main_occ of
Just occ -> [occ]
Nothing -> []
gres = [ gre | occ <- main_occ : demoted_occs
, gre <- lookupGlobalRdrEnv env occ
, gre_name gre == name ]
; case gres of
[] -> -- See Note [Splicing Exact names]
do { lcl_env <- getLocalRdrEnv
......@@ -471,6 +478,19 @@ 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.
There is another wrinkle. With TH and -XDataKinds, consider
$( [d| data Nat = Zero
data T = MkT (Proxy 'Zero) |] )
After splicing, but before renaming we get this:
data Nat_77{tc} = Zero_78{d}
data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc}) |] )
THe occurrence of 'Zero in the data type for T has the right unique,
but it has a TcClsName name-space in its OccName. (This is set by
the ctxt_ns argument of Convert.thRdrName.) When we check that is
in scope in the GlobalRdrEnv, we need to look up the DataName namespace
too. (An alternative would be to make the GlobalRdrEnv also have
a Name -> GRE mapping.)
Note [Usage for sub-bndrs]
~~~~~~~~~~~~~~~~~~~~~~~~~~
If you have this
......@@ -531,18 +551,23 @@ lookupTypeOccRn rdr_name
= do { mb_name <- lookupOccRn_maybe rdr_name
; case mb_name of {
Just name -> return name ;
Nothing ->
do { -- Maybe it's the name of a *data* constructor
data_kinds <- xoptM Opt_DataKinds
; mb_demoted_name <- case demoteRdrName rdr_name of
Just demoted_rdr -> lookupOccRn_maybe demoted_rdr
Nothing -> return Nothing
Nothing -> lookup_demoted rdr_name } }
lookup_demoted :: RdrName -> RnM Name
lookup_demoted rdr_name
| Just demoted_rdr <- demoteRdrName rdr_name
-- Maybe it's the name of a *data* constructor
= do { data_kinds <- xoptM Opt_DataKinds
; mb_demoted_name <- lookupOccRn_maybe demoted_rdr
; case mb_demoted_name of
Nothing -> unboundName WL_Any rdr_name
Just demoted_name
| data_kinds -> return demoted_name
| otherwise -> unboundNameX WL_Any rdr_name suggest_dk }}}
| otherwise -> unboundNameX WL_Any rdr_name suggest_dk }
| otherwise
= unboundName WL_Any rdr_name
where
suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?")
\end{code}
......@@ -663,28 +688,111 @@ lookupGreRn_help rdr_name lookup
; return (Just gre) }
gres -> do { addNameClashErrRn rdr_name gres
; return (Just (head gres)) } }
\end{code}
%*********************************************************
%* *
Deprecations
%* *
%*********************************************************
Note [Handling of deprecations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* We report deprecations at each *occurrence* of the deprecated thing
(see Trac #5867)
* We do not report deprectations for locally-definded names. For a
start, we may be exporting a deprecated thing. Also we may use a
deprecated thing in the defn of another deprecated things. We may
even use a deprecated thing in the defn of a non-deprecated thing,
when changing a module's interface.
* addUsedRdrNames: we do not report deprecations for sub-binders:
- the ".." completion for records
- the ".." in an export item 'T(..)'
- the things exported by a module export 'module M'
\begin{code}
addUsedRdrName :: GlobalRdrElt -> RdrName -> RnM ()
-- Record usage of imported RdrNames
addUsedRdrName gre rdr
| isLocalGRE gre = return ()
| isLocalGRE gre = return () -- No call to warnIfDeprecated
-- See Note [Handling of deprecations]
| otherwise = do { env <- getGblEnv
; updMutVar (tcg_used_rdrnames env)
; warnIfDeprecated gre
; updMutVar (tcg_used_rdrnames env)
(\s -> Set.insert rdr s) }
addUsedRdrNames :: [RdrName] -> RnM ()
-- Record used sub-binders
-- We don't check for imported-ness here, because it's inconvenient
-- and not stritly necessary.
-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations]
addUsedRdrNames rdrs
= do { env <- getGblEnv
; updMutVar (tcg_used_rdrnames env)
(\s -> foldr Set.insert s rdrs) }
------------------------------
-- GHCi support
------------------------------
warnIfDeprecated :: GlobalRdrElt -> RnM ()
warnIfDeprecated gre@(GRE { gre_name = name, gre_prov = Imported (imp_spec : _) })
= do { dflags <- getDynFlags
; when (wopt Opt_WarnWarningsDeprecations dflags) $
do { iface <- loadInterfaceForName doc name
; case lookupImpDeprec iface gre of
Just txt -> addWarn (mk_msg txt)
Nothing -> return () } }
where
mk_msg txt = sep [ sep [ ptext (sLit "In the use of")
<+> pprNonVarNameSpace (occNameSpace (nameOccName name))
<+> quotes (ppr name)
, parens imp_msg <> colon ]
, ppr txt ]
name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
imp_mod = importSpecModule imp_spec
imp_msg = ptext (sLit "imported from") <+> ppr imp_mod <> extra
extra | imp_mod == moduleName name_mod = empty
| otherwise = ptext (sLit ", but defined in") <+> ppr name_mod
doc = ptext (sLit "The name") <+> quotes (ppr name) <+> ptext (sLit "is mentioned explicitly")
warnIfDeprecated _ = return () -- No deprecations for things defined locally
lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt
lookupImpDeprec iface gre
= mi_warn_fn iface (gre_name gre) `mplus` -- Bleat if the thing,
case gre_par gre of -- or its parent, is warn'd
ParentIs p -> mi_warn_fn iface p
NoParent -> Nothing
\end{code}
Note [Used names with interface not loaded]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's (just) possible to to find a used
Name whose interface hasn't been loaded:
a) It might be a WiredInName; in that case we may not load
its interface (although we could).
b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger
These are seen as "used" by the renamer (if -XRebindableSyntax)
is on), but the typechecker may discard their uses
if in fact the in-scope fromRational is GHC.Read.fromRational,
(see tcPat.tcOverloadedLit), and the typechecker sees that the type
is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst).
In that obscure case it won't force the interface in.
In both cases we simply don't permit deprecations;
this is, after all, wired-in stuff.
%*********************************************************
%* *
GHCi support
%* *
%*********************************************************
\begin{code}
-- A qualified name on the command line can refer to any module at all: we
-- try to load the interface if we don't already have it.
lookupQualifiedName :: RdrName -> RnM (Maybe Name)
......@@ -819,30 +927,32 @@ lookupBindGroupOcc ctxt what rdr_name
---------------
lookupLocalDataTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name]
-- GHC extension: look up both the tycon and data con
-- for con-like things. Used for top-level fixity signatures
-- Complain if neither is in scope
lookupLocalDataTcNames bndr_set what rdr_name
lookupLocalTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name]
-- GHC extension: look up both the tycon and data con or variable.
-- Used for top-level fixity signatures. Complain if neither is in scope.
-- See Note [Fixity signature lookup]
lookupLocalTcNames bndr_set what rdr_name
| Just n <- isExact_maybe rdr_name
-- Special case for (:), which doesn't get into the GlobalRdrEnv
= do { n' <- lookupExactOcc n; return [n'] } -- For this we don't need to try the tycon too
| otherwise
= do { mb_gres <- mapM (lookupBindGroupOcc (LocalBindCtxt bndr_set) what)
(dataTcOccs rdr_name)
; let (errs, names) = splitEithers mb_gres
; when (null names) (addErr (head errs)) -- Bleat about one only
; return names }
= do { mb_gres <- mapM lookup (dataTcOccs rdr_name)
; let (errs, names) = splitEithers mb_gres
; when (null names) $ addErr (head errs) -- Bleat about one only
; return names }
where
lookup = lookupBindGroupOcc (LocalBindCtxt bndr_set) what
dataTcOccs :: RdrName -> [RdrName]
-- If the input is a data constructor, return both it and a type
-- constructor. This is useful when we aren't sure which we are
-- looking at.
-- Return both the given name and the same name promoted to the TcClsName
-- namespace. This is useful when we aren't sure which we are looking at.
dataTcOccs rdr_name
| isDataOcc occ = [rdr_name, rdr_name_tc]
| otherwise = [rdr_name]
where
occ = rdrNameOcc rdr_name
| isDataOcc occ || isVarOcc occ
= [rdr_name, rdr_name_tc]
| otherwise
= [rdr_name]
where
occ = rdrNameOcc rdr_name
rdr_name_tc = setRdrNameSpace rdr_name tcName
\end{code}
......@@ -853,6 +963,26 @@ dataTcOccs rdr_name
%* *
%*********************************************************
Note [Fixity signature lookup]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A fixity declaration like
infixr 2 ?
can refer to a value-level operator, e.g.:
(?) :: String -> String -> String
or a type-level operator, like:
data (?) a b = A a | B b
so we extend the lookup of the reader name '?' to the TcClsName namespace, as
well as the original namespace.
The extended lookup is also used in other places, like resolution of
deprecation declarations, and lookup of names in GHCi.
\begin{code}
--------------------------------
type FastStringEnv a = UniqFM a -- Keyed by FastString
......
......@@ -8,7 +8,7 @@ module RnNames (
rnImports, getLocalNonValBinders,
rnExports, extendGlobalRdrEnvRn,
gresFromAvails,
reportUnusedNames, finishWarnings,
reportUnusedNames,
) where
#include "HsVersions.h"
......@@ -904,7 +904,11 @@ rnExports explicit_mod exports
tcg_env@(TcGblEnv { tcg_mod = this_mod,
tcg_rdr_env = rdr_env,
tcg_imports = imports })
= do {
= unsetWOptM Opt_WarnWarningsDeprecations $
-- Do not report deprecations arising from the export
-- list, to avoid bleating about re-exporting a deprecated
-- thing (especially via 'module Foo' export item)
do {
-- If the module header is omitted altogether, then behave
-- as if the user had written "module Main(main) where..."
-- EXCEPT in interactive mode, when we behave as if he had
......@@ -1175,96 +1179,6 @@ dupExport_ok n ie1 ie2
single _ = False
\end{code}
%*********************************************************
%* *
\subsection{Deprecations}
%* *
%*********************************************************
\begin{code}
finishWarnings :: DynFlags -> Maybe WarningTxt
-> TcGblEnv -> RnM TcGblEnv
-- (a) Report usage of imports that are deprecated or have other warnings
-- (b) If the whole module is warned about or deprecated, update tcg_warns
-- All this happens only once per module
finishWarnings dflags mod_warn tcg_env
= do { (eps,hpt) <- getEpsAndHpt
; ifWOptM Opt_WarnWarningsDeprecations $
mapM_ (check hpt (eps_PIT eps)) all_gres
-- By this time, typechecking is complete,
-- so the PIT is fully populated
-- Deal with a module deprecation; it overrides all existing warns
; let new_warns = case mod_warn of
Just txt -> WarnAll txt
Nothing -> tcg_warns tcg_env
; return (tcg_env { tcg_warns = new_warns }) }
where
used_names = allUses (tcg_dus tcg_env)
-- Report on all deprecated uses; hence allUses
all_gres = globalRdrEnvElts (tcg_rdr_env tcg_env)
check hpt pit gre@(GRE {gre_name = name, gre_prov = Imported (imp_spec:_)})
| name `elemNameSet` used_names
, Just deprec_txt <- lookupImpDeprec dflags hpt pit gre
= addWarnAt (importSpecLoc imp_spec)
(sep [ptext (sLit "In the use of") <+>
pprNonVarNameSpace (occNameSpace (nameOccName name)) <+>
quotes (ppr name),
(parens imp_msg) <> colon,
(ppr deprec_txt) ])
where
name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
imp_mod = importSpecModule imp_spec
imp_msg = ptext (sLit "imported from") <+> ppr imp_mod <> extra
extra | imp_mod == moduleName name_mod = empty
| otherwise = ptext (sLit ", but defined in") <+> ppr name_mod
check _ _ _ = return () -- Local, or not used, or not deprectated
-- The Imported pattern-match: don't deprecate locally defined names
-- For a start, we may be exporting a deprecated thing
-- Also we may use a deprecated thing in the defn of another
-- deprecated things. We may even use a deprecated thing in
-- the defn of a non-deprecated thing, when changing a module's
-- interface
lookupImpDeprec :: DynFlags -> HomePackageTable -> PackageIfaceTable
-> GlobalRdrElt -> Maybe WarningTxt
-- The name is definitely imported, so look in HPT, PIT
lookupImpDeprec dflags hpt pit gre
= case lookupIfaceByModule dflags hpt pit mod of
Just iface -> mi_warn_fn iface name `mplus` -- Bleat if the thing, *or
case gre_par gre of
ParentIs p -> mi_warn_fn iface p -- its parent*, is warn'd
NoParent -> Nothing
Nothing -> Nothing -- See Note [Used names with interface not loaded]
where
name = gre_name gre
mod = ASSERT2( isExternalName name, ppr name ) nameModule name
\end{code}
Note [Used names with interface not loaded]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
By now all the interfaces should have been loaded,
because reportDeprecations happens after typechecking.
However, it's still (just) possible to to find a used
Name whose interface hasn't been loaded:
a) It might be a WiredInName; in that case we may not load
its interface (although we could).
b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger
These are seen as "used" by the renamer (if -XRebindableSyntax)
is on), but the typechecker may discard their uses
if in fact the in-scope fromRational is GHC.Read.fromRational,
(see tcPat.tcOverloadedLit), and the typechecker sees that the type
is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst).
In that obscure case it won't force the interface in.
In both cases we simply don't permit deprecations;
this is, after all, wired-in stuff.
%*********************************************************
%* *
......
......@@ -269,7 +269,7 @@ rnSrcFixityDecls bndr_set fix_decls
rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
= setSrcSpan name_loc $
-- this lookup will fail if the definition isn't local
do names <- lookupLocalDataTcNames bndr_set what rdr_name
do names <- lookupLocalTcNames bndr_set what rdr_name
return [ L loc (FixitySig (L name_loc name) fixity)
| name <- names ]
what = ptext (sLit "fixity signature")
......@@ -304,7 +304,7 @@ rnSrcWarnDecls bndr_set decls
where
rn_deprec (Warning rdr_name txt)
-- ensures that the names are defined locally
= do { names <- lookupLocalDataTcNames bndr_set what rdr_name
= do { names <- lookupLocalTcNames bndr_set what rdr_name
; return [(nameOccName name, txt) | name <- names] }
what = ptext (sLit "deprecation")
......
......@@ -354,19 +354,27 @@ For @Case@, the possible ``drop points'' for the \tr{to_drop}
bindings are: (a)~inside the scrutinee, (b)~inside one of the
alternatives/default [default FVs always {\em first}!].
Floating case expressions inward was added to fix Trac #5658: strict bindings
not floated in. In particular, this change allows array indexing operations,
which have a single DEFAULT alternative without any binders, to be floated
inward. SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed
scalars also need to be floated inward, but unpacks have a single non-DEFAULT
alternative that binds the elements of the tuple. We now therefore also support
floating in cases with a single alternative that may bind values.
\begin{code}
fiExpr to_drop (_, AnnCase scrut case_bndr _ [(DEFAULT,[],rhs)])
fiExpr to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)])
| isUnLiftedType (idType case_bndr)
, exprOkForSideEffects (deAnnotate scrut)
= wrapFloats shared_binds $
fiExpr (case_float : rhs_binds) rhs
where
case_float = FB (unitVarSet case_bndr) scrut_fvs
(FloatCase scrut' case_bndr DEFAULT [])
case_float = FB (mkVarSet (case_bndr : alt_bndrs)) scrut_fvs
(FloatCase scrut' case_bndr con alt_bndrs)
scrut' = fiExpr scrut_binds scrut
[shared_binds, scrut_binds, rhs_binds]
= sepBindsByDropPoint False [freeVarsOf scrut, rhs_fvs] to_drop
rhs_fvs = freeVarsOf rhs `delVarSet` case_bndr
rhs_fvs = freeVarsOf rhs `delVarSetList` (case_bndr : alt_bndrs)
scrut_fvs = freeVarsOf scrut
fiExpr to_drop (_, AnnCase scrut case_bndr ty alts)
......
......@@ -254,14 +254,15 @@ addLocalFamInst :: (FamInstEnv,[FamInst]) -> FamInst -> TcM (FamInstEnv, [FamIns
addLocalFamInst (home_fie, my_fis) fam_inst
-- home_fie includes home package and this module
-- my_fies is just the ones from this module
= do { isGHCi <- getIsGHCi
= do { traceTc "addLocalFamInst" (ppr fam_inst)
; isGHCi <- getIsGHCi
-- In GHCi, we *override* any identical instances
-- that are also defined in the interactive context
; let (home_fie', my_fis')
| isGHCi = (deleteFromFamInstEnv home_fie fam_inst,
filterOut (identicalFamInst fam_inst) my_fis)
| otherwise = (home_fie, my_fis)
; let (home_fie', my_fis')
| isGHCi = ( deleteFromFamInstEnv home_fie fam_inst
, filterOut (identicalFamInst fam_inst) my_fis)
| otherwise = (home_fie, my_fis)
-- Load imported instances, so that we report