Commit 69e04fad authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Merge branch 'master' of git://git.haskell.org/ghc

parents dfc51a46 8854d9e2
......@@ -605,7 +605,7 @@ dataConArgRep dflags fam_envs arg_ty
| not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
-- Don't unpack if we aren't optimising; rather arbitrarily,
-- we use -fomit-iface-pragmas as the indication
, let mb_co = topNormaliseType fam_envs arg_ty
, let mb_co = topNormaliseType_maybe fam_envs arg_ty
-- Unwrap type families and newtypes
arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
, isUnpackableType fam_envs arg_ty'
......@@ -712,9 +712,7 @@ isUnpackableType fam_envs ty
where
ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty
where
norm_ty = case topNormaliseType fam_envs ty of
Just (_, ty) -> ty
Nothing -> ty
norm_ty = topNormaliseType fam_envs ty
ok_ty tcs ty
| Just (tc, _) <- splitTyConApp_maybe ty
, let tc_name = getName tc
......
This diff is collapsed.
......@@ -770,28 +770,40 @@ arguments.
-}
areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n) =
cmmOffset dflags (CmmReg spReg) (sp_old - area_off area - n)
areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark) = mkIntExpr dflags sp_hwm
areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) -- Note [Always false stack check]
areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)
= cmmOffset dflags (CmmReg spReg) (sp_old - area_off area - n)
-- Replace (CmmStackSlot area n) with an offset from Sp
areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)
= mkIntExpr dflags sp_hwm
-- Replace CmmHighStackMark with the number of bytes of stack used,
-- the sp_hwm. See Note [Stack usage] in StgCmmHeap
areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _)
[CmmMachOp (MO_Sub _)
[ CmmRegOff (CmmGlobal Sp) off
, CmmLit (CmmInt lit _)],
[ CmmRegOff (CmmGlobal Sp) x_off
, CmmLit (CmmInt y_lit _)],
CmmReg (CmmGlobal SpLim)])
| fromIntegral off == lit = zeroExpr dflags
| fromIntegral x_off >= y_lit
= zeroExpr dflags
-- Replace a stack-overflow test that cannot fail with a no-op
-- See Note [Always false stack check]
areaToSp _ _ _ _ other = other
-- Note [Always false stack check]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- We can optimise stack checks of the form
--
-- if ((Sp + x) - x < SpLim) then .. else ..
-- if ((Sp + x) - y < SpLim) then .. else ..
--
-- where x is an integer offset. Optimising this away depends on knowing that
-- SpLim <= Sp, so it is really the job of the stack layout algorithm, hence we
-- do it now. This is also convenient because sinking pass will later drop the
-- dead code.
-- where are non-negative integer byte offsets. Since we know that
-- SpLim <= Sp (remember the stack grows downwards), this test must
-- yield False if (x >= y), so we can rewrite the comparison to False.
-- A subsequent sinking pass will later drop the dead code.
-- Optimising this away depends on knowing that SpLim <= Sp, so it is
-- really the job of the stack layout algorithm, hence we do it now.
optStackCheck :: CmmNode O C -> CmmNode O C
optStackCheck n = -- Note [null stack check]
......
......@@ -421,8 +421,10 @@ mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
mapForeignTarget _ m@(PrimTarget _) = m
-- Take a transformer on expressions and apply it recursively.
wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
-- Take a transformer on expressions and apply it recursively.
-- (wrapRecExp f e) first recursively applies itself to sub-expressions of e
-- then uses f to rewrite the resulting expression
wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
wrapRecExp f e = f e
......@@ -450,6 +452,8 @@ mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
mapForeignTargetM _ (PrimTarget _) = Nothing
wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
-- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e
-- then gives f a chance to rewrite the resulting expression
wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es)
wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
wrapRecExpM f e = f e
......
......@@ -535,26 +535,52 @@ heapStackCheckGen stk_hwm mb_bytes
-- Note [Single stack check]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~
-- When compiling a function we can determine how much stack space it
-- will use. We therefore need to perform only a single stack check at
-- the beginning of a function to see if we have enough stack space.
--
-- When compiling a function we can determine how much stack space it will
-- use. We therefore need to perform only a single stack check at the beginning
-- of a function to see if we have enough stack space. Instead of referring
-- directly to Sp - as we used to do in the past - the code generator uses
-- (old + 0) in the stack check. Stack layout phase turns (old + 0) into Sp.
-- The check boils down to comparing Sp-N with SpLim, where N is the
-- amount of stack space needed (see Note [Stack usage] below). *BUT*
-- at this stage of the pipeline we are not supposed to refer to Sp
-- itself, because the stack is not yet manifest, so we don't quite
-- know where Sp pointing.
-- So instead of referring directly to Sp - as we used to do in the
-- past - the code generator uses (old + 0) in the stack check. That
-- is the address of the first word of the old area, so if we add N
-- we'll get the address of highest used word.
--
-- The idea here is that, while we need to perform only one stack check for
-- each function, we could in theory place more stack checks later in the
-- function. They would be redundant, but not incorrect (in a sense that they
-- should not change program behaviour). We need to make sure however that a
-- stack check inserted after incrementing the stack pointer checks for a
-- respectively smaller stack space. This would not be the case if the code
-- generator produced direct references to Sp. By referencing (old + 0) we make
-- sure that we always check for a correct amount of stack: when converting
-- (old + 0) to Sp the stack layout phase takes into account changes already
-- made to stack pointer. The idea for this change came from observations made
-- while debugging #8275.
-- This makes the check robust. For example, while we need to perform
-- only one stack check for each function, we could in theory place
-- more stack checks later in the function. They would be redundant,
-- but not incorrect (in a sense that they should not change program
-- behaviour). We need to make sure however that a stack check
-- inserted after incrementing the stack pointer checks for a
-- respectively smaller stack space. This would not be the case if the
-- code generator produced direct references to Sp. By referencing
-- (old + 0) we make sure that we always check for a correct amount of
-- stack: when converting (old + 0) to Sp the stack layout phase takes
-- into account changes already made to stack pointer. The idea for
-- this change came from observations made while debugging #8275.
-- Note [Stack usage]
-- ~~~~~~~~~~~~~~~~~~
-- At the moment we convert from STG to Cmm we don't know N, the
-- number of bytes of stack that the function will use, so we use a
-- special late-bound CmmLit, namely
-- CmmHighStackMark
-- to stand for the number of bytes needed. When the stack is made
-- manifest, the number of bytes needed is calculated, and used to
-- replace occurrences of CmmHighStackMark
--
-- The (Maybe CmmExpr) passed to do_checks is usually
-- Just (CmmLit CmmHighStackMark)
-- but can also (in certain hand-written RTS functions)
-- Just (CmmLit 8) or some other fixed valuet
-- If it is Nothing, we don't generate a stack check at all.
do_checks :: Maybe CmmExpr -- Should we check the stack?
-- See Note [Stack usage]
-> Bool -- Should we check for preemption?
-> Maybe CmmExpr -- Heap headroom (bytes)
-> CmmAGraph -- What to do on failure
......
......@@ -31,6 +31,7 @@ import Module
import RdrName
import NameSet
import NameEnv
import FamInstEnv ( FamInstEnv )
import Rules
import BasicTypes ( Activation(.. ) )
import CoreMonad ( endPass, CoreToDo(..) )
......@@ -90,24 +91,22 @@ deSugar hsc_env
-- Desugar the program
; let export_set = availsToNameSet exports
; let target = hscTarget dflags
; let hpcInfo = emptyHpcInfo other_hpc_info
; (msgs, mb_res) <- do
let want_ticks = gopt Opt_Hpc dflags
target = hscTarget dflags
hpcInfo = emptyHpcInfo other_hpc_info
want_ticks = gopt Opt_Hpc dflags
|| target == HscInterpreted
|| (gopt Opt_SccProfilingOn dflags
&& case profAuto dflags of
NoProfAuto -> False
_ -> True)
(binds_cvr,ds_hpc_info, modBreaks)
; (binds_cvr, ds_hpc_info, modBreaks)
<- if want_ticks && not (isHsBoot hsc_src)
then addTicksToBinds dflags mod mod_loc export_set
(typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks)
initDs hsc_env mod rdr_env type_env $ do
; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
do { ds_ev_binds <- dsEvBinds ev_binds
; core_prs <- dsTopLHsBinds binds_cvr
; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
......@@ -120,14 +119,13 @@ deSugar hsc_env
; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs
, spec_rules ++ ds_rules, ds_vects
, ds_fords `appendStubC` hpc_init
, ds_hpc_info, modBreaks) }
, ds_fords `appendStubC` hpc_init ) }
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do
Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) ->
{ -- Add export flags to bindings
do { -- Add export flags to bindings
keep_alive <- readIORef keep_var
; let (rules_for_locals, rules_for_imps)
= partition isLocalRule all_rules
......@@ -221,24 +219,24 @@ and Rec the rest.
\begin{code}
deSugarExpr :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> LHsExpr Id
-> IO (Messages, Maybe CoreExpr)
-- Prints its own errors; returns Nothing if error occurred
deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
deSugarExpr hsc_env this_mod rdr_env type_env fam_inst_env tc_expr
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Desugar"
-- Do desugaring
; (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
; (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env
type_env fam_inst_env $
dsLExpr tc_expr
; case mb_core_expr of {
Nothing -> return (msgs, Nothing) ;
Just expr ->
-- Dump output
do { dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
......
......@@ -74,6 +74,8 @@ import Util
import Control.Monad( when )
import MonadUtils
import Control.Monad(liftM)
import TcRnMonad (traceIf) -- RAE
\end{code}
%************************************************************************
......@@ -838,15 +840,18 @@ dsTcCoercion :: Role -> TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
-- k (trans g1# g2#)
-- thing_inside will get a coercion at the role requested
dsTcCoercion role co thing_inside
= do { us <- newUniqueSupply
= do { traceIf $ hang (text "dsTcCoercion {") 2 $ vcat [ppr role, ppr co] -- RAE
; us <- newUniqueSupply
; let eqvs_covs :: [(EqVar,CoVar)]
eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co))
(uniqsFromSupply us)
subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
result_expr = thing_inside (ds_tc_coercion subst role co)
ds_co = ds_tc_coercion subst role co -- RAE
result_expr = thing_inside ds_co
result_ty = exprType result_expr
; traceIf $ hang (text "dsTcCoercion }") 2 (ppr ds_co) -- RAE
; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) }
where
mk_co_var :: Id -> Unique -> (Id, Id)
......@@ -875,7 +880,9 @@ ds_tc_coercion subst role tc_co
go r (TcRefl ty) = Refl r (Coercion.substTy subst ty)
go r (TcTyConAppCo tc cos) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) cos)
go r (TcAppCo co1 co2) = mkAppCo (go r co1) (go Nominal co2)
go r (TcAppCo co1 co2) = let leftCo = go r co1
rightRole = nextRole leftCo in
mkAppCoFlexible leftCo rightRole (go rightRole co2)
go r (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' r co)
where
(subst', tv') = Coercion.substTyVarBndr subst tv
......
......@@ -20,6 +20,7 @@ import DsArrows
import DsMonad
import Name
import NameEnv
import FamInstEnv( topNormaliseType )
#ifdef GHCI
-- Template Haskell stuff iff bootstrapped
......@@ -825,31 +826,36 @@ mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
warnDiscardedDoBindings rhs rhs_ty
| Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
= do { -- Warn about discarding non-() things in 'monadic' binding
; warn_unused <- woptM Opt_WarnUnusedDoBind
; if warn_unused && not (isUnitTy elt_ty)
then warnDs (unusedMonadBind rhs elt_ty)
= do { warn_unused <- woptM Opt_WarnUnusedDoBind
; warn_wrong <- woptM Opt_WarnWrongDoBind
; when (warn_unused || warn_wrong) $
do { fam_inst_envs <- dsGetFamInstEnvs
; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
-- Warn about discarding non-() things in 'monadic' binding
; if warn_unused && not (isUnitTy norm_elt_ty)
then warnDs (badMonadBind rhs elt_ty
(ptext (sLit "-fno-warn-unused-do-bind")))
else
-- Warn about discarding m a things in 'monadic' binding of the same type,
-- but only if we didn't already warn due to Opt_WarnUnusedDoBind
do { warn_wrong <- woptM Opt_WarnWrongDoBind
; case tcSplitAppTy_maybe elt_ty of
Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty
-> warnDs (wrongMonadBind rhs elt_ty)
_ -> return () } }
when warn_wrong $
do { case tcSplitAppTy_maybe norm_elt_ty of
Just (elt_m_ty, _)
| m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
-> warnDs (badMonadBind rhs elt_ty
(ptext (sLit "-fno-warn-wrong-do-bind")))
_ -> return () } } }
| otherwise -- RHS does have type of form (m ty), which is weird
= return () -- but at lesat this warning is irrelevant
unusedMonadBind :: LHsExpr Id -> Type -> SDoc
unusedMonadBind rhs elt_ty
= ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
wrongMonadBind :: LHsExpr Id -> Type -> SDoc
wrongMonadBind rhs elt_ty
= ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
badMonadBind :: LHsExpr Id -> Type -> SDoc -> SDoc
badMonadBind rhs elt_ty flag_doc
= vcat [ hang (ptext (sLit "A do-notation statement discarded a result of type"))
2 (quotes (ppr elt_ty))
, hang (ptext (sLit "Suppress this warning by saying"))
2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs)
, ptext (sLit "or by using the flag") <+> flag_doc ]
\end{code}
......@@ -849,8 +849,8 @@ repTy (HsTyLit lit) = do
repTy ty = notHandled "Exotic form of type" (ppr ty)
repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
repTyLit (HsNumTy i) = do dflags <- getDynFlags
rep2 numTyLitName [mkIntExpr dflags i]
repTyLit (HsNumTy i) = do iExpr <- mkIntegerExpr i
rep2 numTyLitName [iExpr]
repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
; rep2 strTyLitName [s']
}
......
......@@ -19,7 +19,7 @@ module DsMonad (
mkPrintUnqualifiedDs,
newUnique,
UniqSupply, newUniqueSupply,
getGhcModeDs,
getGhcModeDs, dsGetFamInstEnvs,
dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
PArrBuiltin(..),
......@@ -38,6 +38,7 @@ module DsMonad (
) where
import TcRnMonad
import FamInstEnv
import CoreSyn
import HsSyn
import TcIface
......@@ -155,6 +156,7 @@ data PArrBuiltin
data DsGblEnv
= DsGblEnv
{ ds_mod :: Module -- For SCC profiling
, ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env
, ds_unqual :: PrintUnqualified
, ds_msgs :: IORef Messages -- Warning messages
, ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
......@@ -187,15 +189,15 @@ data DsMetaVal
-- the PendingSplices on a HsBracketOut
initDs :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> DsM a
-> IO (Messages, Maybe a)
-- Print errors and warnings, if any arise
initDs hsc_env mod rdr_env type_env thing_inside
initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
= do { msg_var <- newIORef (emptyBag, emptyBag)
; let dflags = hsc_dflags hsc_env
(ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env msg_var
(ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var
; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
loadDAP $
......@@ -272,15 +274,17 @@ initDsTc thing_inside
; dflags <- getDynFlags
; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
ds_envs = mkDsEnvs dflags this_mod rdr_env type_env msg_var
fam_inst_env = tcg_fam_inst_env tcg_env
ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env msg_var
; setEnvs ds_envs thing_inside
}
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env msg_var
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> IORef Messages -> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var
= let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
gbl_env = DsGblEnv { ds_mod = mod
, ds_fam_inst_env = fam_inst_env
, ds_if_env = (if_genv, if_lenv)
, ds_unqual = mkPrintUnqualified dflags rdr_env
, ds_msgs = msg_var
......@@ -475,6 +479,13 @@ dsInitPArrBuiltin thing_inside
\end{code}
\begin{code}
dsGetFamInstEnvs :: DsM FamInstEnvs
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
dsGetFamInstEnvs
= do { eps <- getEps; env <- getGblEnv
; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
dsGetMetaEnv = do { env <- getLclEnv; return (ds_meta env) }
......
......@@ -1053,9 +1053,10 @@ tName n = cvtName OccName.tvName n
tconNameL n = wrapL (tconName n)
tconName n = cvtName OccName.tcClsName n
-- See Note [Checking name spaces]
cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
cvtName ctxt_ns (TH.Name occ flavour)
| not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
| otherwise
= do { loc <- getL
; let rdr_name = thRdrName loc ctxt_ns occ_str flavour
; force rdr_name
......@@ -1063,6 +1064,15 @@ cvtName ctxt_ns (TH.Name occ flavour)
where
occ_str = TH.occString occ
okOcc :: OccName.NameSpace -> String -> Bool
okOcc _ [] = False
okOcc ns str@(c:_)
| OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
| OccName.isDataConNameSpace ns = startsConId c || startsConSym c || str == "[]"
| otherwise = startsConId c || startsConSym c ||
startsVarSym c || str == "[]" || str == "->"
-- allow type operators like "+"
-- Determine the name space of a name in a type
--
isVarName :: TH.Name -> Bool
......@@ -1071,6 +1081,11 @@ isVarName (TH.Name occ _)
"" -> False
(c:_) -> startsVarId c || startsVarSym c
badOcc :: OccName.NameSpace -> String -> SDoc
badOcc ctxt_ns occ
= ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
<+> ptext (sLit "name:") <+> quotes (text occ)
thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
-- This turns a TH Name into a RdrName; used for both binders and occurrences
-- See Note [Binders in Template Haskell]
......@@ -1205,14 +1220,3 @@ the way System Names are printed.
There's a small complication of course; see Note [Looking up Exact
RdrNames] in RnEnv.
Note [Checking name spaces]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
In cvtName, it's possible that the name we are converting doesn't
match the namespace requested. For example, we might have a data
constructor "foo" or a variable "Bar". We could check for these cases,
but it seems difficult to guarantee identical behavior to the parser.
Furthermore, a TH user might (somewhat dirtily) want to violate Haskell's
naming expectations, and to use a name that couldn't be used in source
code. So, according to the discussion in #7667, we just don't check.
If you're thinking of changing this behavior, also please do see #7484,
which is closely related.
......@@ -1353,6 +1353,8 @@ hscStmtWithLocation hsc_env0 stmt source linenumber =
let icntxt = hsc_IC hsc_env
rdr_env = ic_rn_gbl_env icntxt
type_env = mkTypeEnvWithImplicits (ic_tythings icntxt)
fam_insts = snd (ic_instances icntxt)
fam_inst_env = extendFamInstEnvList emptyFamInstEnv fam_insts
src_span = srcLocSpan interactiveSrcLoc
-- Rename and typecheck it
......@@ -1362,7 +1364,7 @@ hscStmtWithLocation hsc_env0 stmt source linenumber =
-- Desugar it
ds_expr <- ioMsgMaybe $
deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
deSugarExpr hsc_env iNTERACTIVE rdr_env type_env fam_inst_env tc_expr
liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
handleWarnings
......
......@@ -197,18 +197,22 @@ pprTyCon ss tyCon
-- e.g. type T = forall a. a->a
| Just cls <- tyConClass_maybe tyCon
= pp_roles $$ pprClass ss cls
= (pp_roles (== Nominal)) $$ pprClass ss cls
| otherwise
= pp_roles $$ pprAlgTyCon ss tyCon
= (pp_roles (== Representational)) $$ pprAlgTyCon ss tyCon
where
pp_roles = sdocWithDynFlags $ \dflags ->
-- if, for each role, suppress_if role is True, then suppress the role
-- output
pp_roles :: (Role -> Bool) -> SDoc
pp_roles suppress_if
= sdocWithDynFlags $ \dflags ->
let roles = suppressKinds dflags (tyConKind tyCon) (tyConRoles tyCon)
in ppUnless (all (== Representational) roles) $
in ppUnless (all suppress_if roles) $
ptext (sLit "type role") <+> ppr tyCon <+> hsep (map ppr roles)
pp_tc_with_kind = vcat [ pp_roles
pp_tc_with_kind = vcat [ pp_roles (const True)
, pprTyConHdr tyCon <+> dcolon
<+> pprTypeForUser (synTyConResKind tyCon) ]
closed_family_header
......
......@@ -53,6 +53,9 @@ import RnEnv
import RnTypes
import DynFlags
import PrelNames
import TyCon ( tyConName )
import DataCon ( dataConTyCon )
import TypeRep ( TyThing(..) )
import Name
import NameSet
import RdrName
......@@ -609,9 +612,14 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
-- That is, the parent of the data constructor.
-- That's the parent to use for looking up record fields.
find_tycon env con
= case lookupGRE_Name env con of
[GRE { gre_par = ParentIs p }] -> p
gres -> pprPanic "find_tycon" (ppr con $$ ppr gres)
| Just (ADataCon dc) <- wiredInNameTyThing_maybe con
= tyConName (dataConTyCon dc) -- Special case for [], which is built-in syntax
-- and not in the GlobalRdrEnv (Trac #8448)
| [GRE { gre_par = ParentIs p }] <- lookupGRE_Name env con
= p
| otherwise
= pprPanic "find_tycon" (ppr con $$ ppr (lookupGRE_Name env con))
dup_flds :: [[RdrName]]
-- Each list represents a RdrName that occurred more than once
......
......@@ -22,7 +22,7 @@ import IdInfo
import Name ( mkSystemVarName, isExternalName )
import Coercion hiding ( substCo, substTy, substCoVar, extendTvSubst )
import OptCoercion ( optCoercion )
import FamInstEnv ( topNormaliseType )
import FamInstEnv ( topNormaliseType_maybe )
import DataCon ( DataCon, dataConWorkId, dataConRepStrictness
, isMarkedStrict ) --, dataConTyCon, dataConTag, fIRST_TAG )
--import TyCon ( isEnumerationTyCon ) -- temporalily commented out. See #8326
......@@ -2060,7 +2060,7 @@ improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
-- Note [Improving seq]
improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
| not (isDeadBinder case_bndr) -- Not a pure seq! See Note [Improving seq]
, Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
, Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)
= do { case_bndr2 <- newId (fsLit "nt") ty2
; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co)
env2 = extendIdSubst env case_bndr rhs
......@@ -2666,6 +2666,7 @@ e.g. f E [..hole..]
But this is terrible! Here's an example:
&& E (case x of { T -> F; F -> T })
Now, && is strict so we end up simplifying the case with
an ArgOf continuation. If we let-bind it, we get
let $j = \v -> && E v
in simplExpr (case x of { T -> F; F -> T })
......
......@@ -144,7 +144,8 @@ import Control.Monad (liftM, ap)
-- to the code for `x'.
--
-- All of this is provided x is:
-- 1. non-updatable;
-- 1. non-updatable - it must have at least one parameter (see Note
-- [Join point abstraction]);
-- 2. guaranteed to be entered before the stack retreats -- ie x is not
-- buried in a heap-allocated closure, or passed as an argument to
-- something;
......
......@@ -39,6 +39,7 @@ import Id( idType )
import Class
import Type
import Kind( isKind )
import Coercion ( tvUsedAtNominalRole )
import ErrUtils
import MkId
import DataCon
......@@ -1472,11 +1473,24 @@ mkNewTypeEqn orig dflags tvs
-- currently generate type 'instance' decls; and cannot do
-- so for 'data' instance decls
roles_ok = let cls_roles = tyConRoles (classTyCon cls) in
not (null cls_roles) && last cls_roles /= Nominal
-- We must make sure that the class definition (and all its
-- members) never pattern-match on the last parameter.
-- See Trac #1496 and Note [Roles] in Coercion
-- We must make sure that all of the class's members
-- never pattern-match on the last parameter.
-- See Trac #1496 and Note [Roles] in Coercion.
-- Also see Note [Role checking in GND]
roles_ok = null role_errs
role_errs
= [ (id, substed_ty, is_specialized)
| id <- classMethods cls
, let ty = idType id
(_, [cls_constraint], meth_ty) = tcSplitSigmaTy ty
(_cls_tc, cls_args) = splitTyConApp cls_constraint
ordered_tvs = map (getTyVar "mkNewTypeEqn") cls_args
Just (other_tvs, gnd_tv) = snocView ordered_tvs
subst = zipOpenTvSubst other_tvs cls_tys
substed_ty = substTy subst meth_ty
is_specialized = not (meth_ty `eqType` substed_ty)
, ASSERT( _cls_tc == classTyCon cls )
tvUsedAtNominalRole gnd_tv substed_ty ]
cant_derive_err
= vcat [ ppUnless arity_ok arity_msg
......@@ -1488,9 +1502,15 @@ mkNewTypeEqn orig dflags tvs
ats_msg = ptext (sLit "the class has associated types")
roles_msg = ptext (sLit "it is not type-safe to use") <+>
ptext (sLit "GeneralizedNewtypeDeriving on this class;") $$
ptext (sLit "the last parameter of") <+>
quotes (ppr (className cls)) <+>
ptext (sLit "is at role Nominal")