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,29 +535,55 @@ 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?
-> Bool -- Should we check for preemption?
-- See Note [Stack usage]
-> Bool -- Should we check for preemption?
-> Maybe CmmExpr -- Heap headroom (bytes)
-> CmmAGraph -- What to do on failure
-> CmmAGraph -- What to do on failure
-> FCode ()
do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
dflags <- getDynFlags
......
......@@ -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 == HscInterpreted
|| (gopt Opt_SccProfilingOn dflags
&& case profAuto dflags of
NoProfAuto -> False
_ -> True)
(binds_cvr,ds_hpc_info, modBreaks)
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)
<- 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,23 +219,23 @@ 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)
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 () } }
= 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
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
......@@ -154,7 +155,8 @@ data PArrBuiltin
data DsGblEnv
= DsGblEnv
{ ds_mod :: Module -- For SCC profiling
{ 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
......@@ -470,11 +474,18 @@ dsInitPArrBuiltin thing_inside
where
externalVar :: FastString -> DsM Var
externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
arithErr = panic "Arithmetic sequences have to wait until we support type classes"
\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.
......@@ -1350,10 +1350,12 @@ hscStmtWithLocation hsc_env0 stmt source linenumber =
Nothing -> return Nothing
Just parsed_stmt -> do
let icntxt = hsc_IC hsc_env
rdr_env = ic_rn_gbl_env icntxt
type_env = mkTypeEnvWithImplicits (ic_tythings icntxt)
src_span = srcLocSpan interactiveSrcLoc
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
-- Here we lift the stmt into the IO monad, see Note
......@@ -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 ->
let roles = suppressKinds dflags (tyConKind tyCon) (tyConRoles tyCon)
in ppUnless (all (== Representational) roles) $
ptext (sLit "type role") <+> ppr tyCon <+> hsep (map ppr roles)
pp_tc_with_kind = vcat [ pp_roles
-- 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 suppress_if roles) $
ptext (sLit "type role") <+> ppr tyCon <+> hsep (map ppr 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
......@@ -1451,7 +1451,7 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con
res = argInfoExpr fun rev_args
cont_ty = contResultType cont
rebuildCall env info (CoerceIt co cont)
rebuildCall env info (CoerceIt co cont)
= rebuildCall env (addCastTo info co) cont
rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
......@@ -1574,28 +1574,28 @@ tryRules env rules fn args call_cont
; let enum_to_tag :: CoreAlt -> CoreAlt
-- Takes K -> e into tagK# -> e
-- where tagK# is the tag of constructor K
enum_to_tag (DataAlt con, [], rhs)
enum_to_tag (DataAlt con, [], rhs)
= ASSERT( isEnumerationTyCon (dataConTyCon con) )
(LitAlt tag, [], rhs)
where
tag = mkMachInt dflags (toInteger (dataConTag con - fIRST_TAG))
enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)
new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts
new_bndr = setIdType bndr intPrimTy
new_bndr = setIdType bndr intPrimTy
-- The binder is dead, but should have the right type
; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }
-}
| otherwise
= do { dflags <- getDynFlags
; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env)
; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env)
fn args rules of {
Nothing -> return Nothing ; -- No rule matches
Just (rule, rule_rhs) ->
do { checkedTick (RuleFired (ru_name rule))
; dump dflags rule rule_rhs
; let cont' = pushSimplifiedArgs env
(drop (ruleArity rule) args)
(drop (ruleArity rule) args)
call_cont
-- (ruleArity rule) says how many args the rule consumed
; return (Just (rule_rhs, cont')) }}}
......@@ -1727,7 +1727,7 @@ because that builds an unnecessary thunk.
Note [Case binder next]
~~~~~~~~~~~~~~~~~~~~~~~
If we have
If we have
case e of f { _ -> f e1 e2 }
then we can safely do CaseElim. The main criterion is that the
case-binder is evaluated *next*. Previously we just asked that
......@@ -1736,7 +1736,7 @@ the case-binder is used strictly; but that can change
--> error "bad"
which is very puzzling if 'x' is later bound to (error "good").
Where the order of evaluation is specified (via seq or case)
we should respect it.
we should respect it.
See also Note [Empty case alternatives] in CoreSyn.
So instead we use case_bndr_evald_next to see when f is the *next*
......@@ -1970,7 +1970,7 @@ Note [Case alternative occ info]
When we are simply reconstructing a case (the common case), we always
zap the occurrence info on the binders in the alternatives. Even
if the case binder is dead, the scrutinee is usually a variable, and *that*
can bring the case-alternative binders back to life.
can bring the case-alternative binders back to life.
See Note [Add unfolding for scrutinee]
Note [Improving seq]
......@@ -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
......@@ -2146,15 +2146,15 @@ addAltUnfoldings env scrut case_bndr con_app
Just (Cast (Var v) co) -> addBinderUnfolding env1 v $
mkSimpleUnfolding dflags (Cast con_app (mkSymCo co))
_ -> env1
; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])
; return env2 }
addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv
addBinderUnfolding env bndr unf
| debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf
= WARN( not (eqType (idType bndr) (exprType tmpl)),
ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) )
= WARN( not (eqType (idType bndr) (exprType tmpl)),
ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) )
modifyInScope env (bndr `setIdUnfolding` unf)
| otherwise
......@@ -2198,7 +2198,7 @@ HOWEVER, given
we do not want to add the unfolding x -> y to 'x', which might seem cool,
since 'y' itself has different unfoldings in r1 and r2. Reason: if we
did that, we'd have to zap y's deadness info and that is a very useful
piece of information.
piece of information.
So instead we add the unfolding x -> Just a, and x -> Nothing in the
respective RHSs.
......@@ -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