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 ...@@ -605,7 +605,7 @@ dataConArgRep dflags fam_envs arg_ty
| not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
-- Don't unpack if we aren't optimising; rather arbitrarily, -- Don't unpack if we aren't optimising; rather arbitrarily,
-- we use -fomit-iface-pragmas as the indication -- 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 -- Unwrap type families and newtypes
arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty } arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
, isUnpackableType fam_envs arg_ty' , isUnpackableType fam_envs arg_ty'
...@@ -712,9 +712,7 @@ isUnpackableType fam_envs ty ...@@ -712,9 +712,7 @@ isUnpackableType fam_envs ty
where where
ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty
where where
norm_ty = case topNormaliseType fam_envs ty of norm_ty = topNormaliseType fam_envs ty
Just (_, ty) -> ty
Nothing -> ty
ok_ty tcs ty ok_ty tcs ty
| Just (tc, _) <- splitTyConApp_maybe ty | Just (tc, _) <- splitTyConApp_maybe ty
, let tc_name = getName tc , let tc_name = getName tc
......
This diff is collapsed.
...@@ -770,28 +770,40 @@ arguments. ...@@ -770,28 +770,40 @@ arguments.
-} -}
areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr 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_old _sp_hwm area_off (CmmStackSlot area n)
areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark) = mkIntExpr dflags sp_hwm = cmmOffset dflags (CmmReg spReg) (sp_old - area_off area - n)
areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) -- Note [Always false stack check] -- 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 _) [CmmMachOp (MO_Sub _)
[ CmmRegOff (CmmGlobal Sp) off [ CmmRegOff (CmmGlobal Sp) x_off
, CmmLit (CmmInt lit _)], , CmmLit (CmmInt y_lit _)],
CmmReg (CmmGlobal SpLim)]) 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 areaToSp _ _ _ _ other = other
-- Note [Always false stack check] -- Note [Always false stack check]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- We can optimise stack checks of the form -- 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 -- where are non-negative integer byte offsets. Since we know that
-- SpLim <= Sp, so it is really the job of the stack layout algorithm, hence we -- SpLim <= Sp (remember the stack grows downwards), this test must
-- do it now. This is also convenient because sinking pass will later drop the -- yield False if (x >= y), so we can rewrite the comparison to False.
-- dead code. -- 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 :: CmmNode O C -> CmmNode O C
optStackCheck n = -- Note [null stack check] optStackCheck n = -- Note [null stack check]
......
...@@ -421,8 +421,10 @@ mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget ...@@ -421,8 +421,10 @@ mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
mapForeignTarget _ m@(PrimTarget _) = m mapForeignTarget _ m@(PrimTarget _) = m
-- Take a transformer on expressions and apply it recursively.
wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr 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 (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty) wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
wrapRecExp f e = f e wrapRecExp f e = f e
...@@ -450,6 +452,8 @@ mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e ...@@ -450,6 +452,8 @@ mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
mapForeignTargetM _ (PrimTarget _) = Nothing mapForeignTargetM _ (PrimTarget _) = Nothing
wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr) 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@(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 n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
wrapRecExpM f e = f e wrapRecExpM f e = f e
......
...@@ -535,29 +535,55 @@ heapStackCheckGen stk_hwm mb_bytes ...@@ -535,29 +535,55 @@ heapStackCheckGen stk_hwm mb_bytes
-- Note [Single stack check] -- 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 -- The check boils down to comparing Sp-N with SpLim, where N is the
-- use. We therefore need to perform only a single stack check at the beginning -- amount of stack space needed (see Note [Stack usage] below). *BUT*
-- of a function to see if we have enough stack space. Instead of referring -- at this stage of the pipeline we are not supposed to refer to Sp
-- directly to Sp - as we used to do in the past - the code generator uses -- itself, because the stack is not yet manifest, so we don't quite
-- (old + 0) in the stack check. Stack layout phase turns (old + 0) into Sp. -- 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 -- This makes the check robust. For example, while we need to perform
-- each function, we could in theory place more stack checks later in the -- only one stack check for each function, we could in theory place
-- function. They would be redundant, but not incorrect (in a sense that they -- more stack checks later in the function. They would be redundant,
-- should not change program behaviour). We need to make sure however that a -- but not incorrect (in a sense that they should not change program
-- stack check inserted after incrementing the stack pointer checks for a -- behaviour). We need to make sure however that a stack check
-- respectively smaller stack space. This would not be the case if the code -- inserted after incrementing the stack pointer checks for a
-- generator produced direct references to Sp. By referencing (old + 0) we make -- respectively smaller stack space. This would not be the case if the
-- sure that we always check for a correct amount of stack: when converting -- code generator produced direct references to Sp. By referencing
-- (old + 0) to Sp the stack layout phase takes into account changes already -- (old + 0) we make sure that we always check for a correct amount of
-- made to stack pointer. The idea for this change came from observations made -- stack: when converting (old + 0) to Sp the stack layout phase takes
-- while debugging #8275. -- 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? 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) -> Maybe CmmExpr -- Heap headroom (bytes)
-> CmmAGraph -- What to do on failure -> CmmAGraph -- What to do on failure
-> FCode () -> FCode ()
do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
dflags <- getDynFlags dflags <- getDynFlags
......
...@@ -31,6 +31,7 @@ import Module ...@@ -31,6 +31,7 @@ import Module
import RdrName import RdrName
import NameSet import NameSet
import NameEnv import NameEnv
import FamInstEnv ( FamInstEnv )
import Rules import Rules
import BasicTypes ( Activation(.. ) ) import BasicTypes ( Activation(.. ) )
import CoreMonad ( endPass, CoreToDo(..) ) import CoreMonad ( endPass, CoreToDo(..) )
...@@ -90,24 +91,22 @@ deSugar hsc_env ...@@ -90,24 +91,22 @@ deSugar hsc_env
-- Desugar the program -- Desugar the program
; let export_set = availsToNameSet exports ; let export_set = availsToNameSet exports
; let target = hscTarget dflags target = hscTarget dflags
; let hpcInfo = emptyHpcInfo other_hpc_info hpcInfo = emptyHpcInfo other_hpc_info
; (msgs, mb_res) <- do want_ticks = gopt Opt_Hpc dflags
|| target == HscInterpreted
let want_ticks = gopt Opt_Hpc dflags || (gopt Opt_SccProfilingOn dflags
|| target == HscInterpreted && case profAuto dflags of
|| (gopt Opt_SccProfilingOn dflags NoProfAuto -> False
&& case profAuto dflags of _ -> True)
NoProfAuto -> False
_ -> True) ; (binds_cvr, ds_hpc_info, modBreaks)
(binds_cvr,ds_hpc_info, modBreaks)
<- if want_ticks && not (isHsBoot hsc_src) <- if want_ticks && not (isHsBoot hsc_src)
then addTicksToBinds dflags mod mod_loc export_set then addTicksToBinds dflags mod mod_loc export_set
(typeEnvTyCons type_env) binds (typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks) 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 do { ds_ev_binds <- dsEvBinds ev_binds
; core_prs <- dsTopLHsBinds binds_cvr ; core_prs <- dsTopLHsBinds binds_cvr
; (spec_prs, spec_rules) <- dsImpSpecs imp_specs ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
...@@ -120,14 +119,13 @@ deSugar hsc_env ...@@ -120,14 +119,13 @@ deSugar hsc_env
; return ( ds_ev_binds ; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs , foreign_prs `appOL` core_prs `appOL` spec_prs
, spec_rules ++ ds_rules, ds_vects , spec_rules ++ ds_rules, ds_vects
, ds_fords `appendStubC` hpc_init , ds_fords `appendStubC` hpc_init ) }
, ds_hpc_info, modBreaks) }
; case mb_res of { ; case mb_res of {
Nothing -> return (msgs, Nothing) ; 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 keep_alive <- readIORef keep_var
; let (rules_for_locals, rules_for_imps) ; let (rules_for_locals, rules_for_imps)
= partition isLocalRule all_rules = partition isLocalRule all_rules
...@@ -221,23 +219,23 @@ and Rec the rest. ...@@ -221,23 +219,23 @@ and Rec the rest.
\begin{code} \begin{code}
deSugarExpr :: HscEnv deSugarExpr :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> LHsExpr Id -> LHsExpr Id
-> IO (Messages, Maybe CoreExpr) -> IO (Messages, Maybe CoreExpr)
-- Prints its own errors; returns Nothing if error occurred -- 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 = do { let dflags = hsc_dflags hsc_env
; showPass dflags "Desugar" ; showPass dflags "Desugar"
-- Do desugaring -- 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 dsLExpr tc_expr
; case mb_core_expr of { ; case mb_core_expr of {
Nothing -> return (msgs, Nothing) ; Nothing -> return (msgs, Nothing) ;
Just expr -> Just expr ->
-- Dump output -- Dump output
do { dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr) do { dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
......
...@@ -74,6 +74,8 @@ import Util ...@@ -74,6 +74,8 @@ import Util
import Control.Monad( when ) import Control.Monad( when )
import MonadUtils import MonadUtils
import Control.Monad(liftM) import Control.Monad(liftM)
import TcRnMonad (traceIf) -- RAE
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -838,15 +840,18 @@ dsTcCoercion :: Role -> TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr ...@@ -838,15 +840,18 @@ dsTcCoercion :: Role -> TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
-- k (trans g1# g2#) -- k (trans g1# g2#)
-- thing_inside will get a coercion at the role requested -- thing_inside will get a coercion at the role requested
dsTcCoercion role co thing_inside 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)] ; let eqvs_covs :: [(EqVar,CoVar)]
eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co)) eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co))
(uniqsFromSupply us) (uniqsFromSupply us)
subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs] 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 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) } ; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) }
where where
mk_co_var :: Id -> Unique -> (Id, Id) mk_co_var :: Id -> Unique -> (Id, Id)
...@@ -875,7 +880,9 @@ ds_tc_coercion subst role tc_co ...@@ -875,7 +880,9 @@ ds_tc_coercion subst role tc_co
go r (TcRefl ty) = Refl r (Coercion.substTy subst ty) 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 (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) go r (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' r co)
where where
(subst', tv') = Coercion.substTyVarBndr subst tv (subst', tv') = Coercion.substTyVarBndr subst tv
......
...@@ -20,6 +20,7 @@ import DsArrows ...@@ -20,6 +20,7 @@ import DsArrows
import DsMonad import DsMonad
import Name import Name
import NameEnv import NameEnv
import FamInstEnv( topNormaliseType )
#ifdef GHCI #ifdef GHCI
-- Template Haskell stuff iff bootstrapped -- Template Haskell stuff iff bootstrapped
...@@ -825,31 +826,36 @@ mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ ...@@ -825,31 +826,36 @@ mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
warnDiscardedDoBindings rhs rhs_ty warnDiscardedDoBindings rhs rhs_ty
| Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
= do { -- Warn about discarding non-() things in 'monadic' binding = do { warn_unused <- woptM Opt_WarnUnusedDoBind
; warn_unused <- woptM Opt_WarnUnusedDoBind ; warn_wrong <- woptM Opt_WarnWrongDoBind
; if warn_unused && not (isUnitTy elt_ty) ; when (warn_unused || warn_wrong) $
then warnDs (unusedMonadBind rhs elt_ty) do { fam_inst_envs <- dsGetFamInstEnvs
else ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
-- 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 -- Warn about discarding non-() things in 'monadic' binding
do { warn_wrong <- woptM Opt_WarnWrongDoBind ; if warn_unused && not (isUnitTy norm_elt_ty)
; case tcSplitAppTy_maybe elt_ty of then warnDs (badMonadBind rhs elt_ty
Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty (ptext (sLit "-fno-warn-unused-do-bind")))
-> warnDs (wrongMonadBind rhs elt_ty) else
_ -> return () } }
-- 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 | otherwise -- RHS does have type of form (m ty), which is weird
= return () -- but at lesat this warning is irrelevant = return () -- but at lesat this warning is irrelevant
unusedMonadBind :: LHsExpr Id -> Type -> SDoc badMonadBind :: LHsExpr Id -> Type -> SDoc -> SDoc
unusedMonadBind rhs elt_ty badMonadBind rhs elt_ty flag_doc
= ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$ = vcat [ hang (ptext (sLit "A do-notation statement discarded a result of type"))
ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$ 2 (quotes (ppr elt_ty))
ptext (sLit "or by using the flag -fno-warn-unused-do-bind") , hang (ptext (sLit "Suppress this warning by saying"))
2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs)
wrongMonadBind :: LHsExpr Id -> Type -> SDoc , ptext (sLit "or by using the flag") <+> flag_doc ]
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")
\end{code} \end{code}
...@@ -849,8 +849,8 @@ repTy (HsTyLit lit) = do ...@@ -849,8 +849,8 @@ repTy (HsTyLit lit) = do
repTy ty = notHandled "Exotic form of type" (ppr ty) repTy ty = notHandled "Exotic form of type" (ppr ty)
repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ) repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
repTyLit (HsNumTy i) = do dflags <- getDynFlags repTyLit (HsNumTy i) = do iExpr <- mkIntegerExpr i
rep2 numTyLitName [mkIntExpr dflags i] rep2 numTyLitName [iExpr]
repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
; rep2 strTyLitName [s'] ; rep2 strTyLitName [s']
} }
......
...@@ -19,7 +19,7 @@ module DsMonad ( ...@@ -19,7 +19,7 @@ module DsMonad (
mkPrintUnqualifiedDs, mkPrintUnqualifiedDs,
newUnique, newUnique,
UniqSupply, newUniqueSupply, UniqSupply, newUniqueSupply,
getGhcModeDs, getGhcModeDs, dsGetFamInstEnvs,
dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon, dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
PArrBuiltin(..), PArrBuiltin(..),
...@@ -38,6 +38,7 @@ module DsMonad ( ...@@ -38,6 +38,7 @@ module DsMonad (
) where ) where
import TcRnMonad import TcRnMonad
import FamInstEnv
import CoreSyn import CoreSyn
import HsSyn import HsSyn
import TcIface import TcIface
...@@ -154,7 +155,8 @@ data PArrBuiltin ...@@ -154,7 +155,8 @@ data PArrBuiltin
data DsGblEnv data DsGblEnv
= 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_unqual :: PrintUnqualified
, ds_msgs :: IORef Messages -- Warning messages , ds_msgs :: IORef Messages -- Warning messages
, ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
...@@ -187,15 +189,15 @@ data DsMetaVal ...@@ -187,15 +189,15 @@ data DsMetaVal
-- the PendingSplices on a HsBracketOut -- the PendingSplices on a HsBracketOut
initDs :: HscEnv initDs :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> DsM a -> DsM a
-> IO (Messages, Maybe a) -> IO (Messages, Maybe a)
-- Print errors and warnings, if any arise -- 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) = do { msg_var <- newIORef (emptyBag, emptyBag)
; let dflags = hsc_dflags hsc_env ; 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 $ ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
loadDAP $ loadDAP $
...@@ -272,15 +274,17 @@ initDsTc thing_inside ...@@ -272,15 +274,17 @@ initDsTc thing_inside
; dflags <- getDynFlags ; dflags <- getDynFlags
; let type_env = tcg_type_env tcg_env ; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_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 ; setEnvs ds_envs thing_inside
} }
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> (DsGblEnv, DsLclEnv) mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> IORef Messages -> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env msg_var mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var
= let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) } = 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) if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
gbl_env = DsGblEnv { ds_mod = mod gbl_env = DsGblEnv { ds_mod = mod
, ds_fam_inst_env = fam_inst_env
, ds_if_env = (if_genv, if_lenv) , ds_if_env = (if_genv, if_lenv)
, ds_unqual = mkPrintUnqualified dflags rdr_env , ds_unqual = mkPrintUnqualified dflags rdr_env
, ds_msgs = msg_var , ds_msgs = msg_var
...@@ -470,11 +474,18 @@ dsInitPArrBuiltin thing_inside ...@@ -470,11 +474,18 @@ dsInitPArrBuiltin thing_inside
where where
externalVar :: FastString -> DsM Var externalVar :: FastString -> DsM Var
externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
arithErr = panic "Arithmetic sequences have to wait until we support type classes" arithErr = panic "Arithmetic sequences have to wait until we support type classes"
\end{code} \end{code}
\begin{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 :: DsM (NameEnv DsMetaVal)
dsGetMetaEnv = do { env <- getLclEnv; return (ds_meta env) } dsGetMetaEnv = do { env <- getLclEnv; return (ds_meta env) }
......
...@@ -1053,9 +1053,10 @@ tName n = cvtName OccName.tvName n ...@@ -1053,9 +1053,10 @@ tName n = cvtName OccName.tvName n
tconNameL n = wrapL (tconName n) tconNameL n = wrapL (tconName n)
tconName n = cvtName OccName.tcClsName n tconName n = cvtName OccName.tcClsName n
-- See Note [Checking name spaces]
cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
cvtName ctxt_ns (TH.Name occ flavour) cvtName ctxt_ns (TH.Name occ flavour)
| not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
| otherwise
= do { loc <- getL = do { loc <- getL
; let rdr_name = thRdrName loc ctxt_ns occ_str flavour ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour
; force rdr_name ; force rdr_name
...@@ -1063,6 +1064,15 @@ cvtName ctxt_ns (TH.Name occ flavour) ...@@ -1063,6 +1064,15 @@ cvtName ctxt_ns (TH.Name occ flavour)
where where
occ_str = TH.occString occ 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 -- Determine the name space of a name in a type
-- --
isVarName :: TH.Name -> Bool isVarName :: TH.Name -> Bool
...@@ -1071,6 +1081,11 @@ isVarName (TH.Name occ _) ...@@ -1071,6 +1081,11 @@ isVarName (TH.Name occ _)
"" -> False "" -> False
(c:_) -> startsVarId c || startsVarSym c (c:_) -> startsVarId c || startsVarSym c