summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ghc/compiler/main/MkIface.lhs8
-rw-r--r--ghc/compiler/reader/Lex.lhs4
-rw-r--r--ghc/compiler/simplCore/SimplCase.lhs31
-rw-r--r--ghc/compiler/simplCore/SimplEnv.lhs22
-rw-r--r--ghc/compiler/simplCore/SimplVar.lhs2
-rw-r--r--ghc/compiler/simplCore/Simplify.lhs20
-rw-r--r--ghc/compiler/specialise/Specialise.lhs12
-rw-r--r--ghc/compiler/typecheck/TcSimplify.lhs45
8 files changed, 104 insertions, 40 deletions
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 5b5c2139e4..cc8dc37425 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -41,6 +41,7 @@ import IdInfo ( IdInfo, StrictnessInfo, ArityInfo,
arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo,
bottomIsGuaranteed, workerExists,
)
+import PragmaInfo ( PragmaInfo(..) )
import CoreSyn ( CoreExpr, CoreBinding, GenCoreExpr, GenCoreBinding(..) )
import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding )
import FreeVars ( addExprFVs )
@@ -287,9 +288,14 @@ ifaceId get_idinfo needed_ids is_rec id rhs
con_list = idSetToList wrapper_cons
------------ Unfolding --------------
- unfold_pretty | show_unfold = hsep [ptext SLIT("_U_"), pprIfaceUnfolding rhs]
+ unfold_pretty | show_unfold = hsep [ptext unfold_herald, pprIfaceUnfolding rhs]
| otherwise = empty
+ unfold_herald = case inline_pragma of
+ IMustBeINLINEd -> SLIT("_U_")
+ IWantToBeINLINEd -> SLIT("_U_")
+ other -> SLIT("_u_")
+
show_unfold = not implicit_unfolding && -- Not unnecessary
not dodgy_unfolding -- Not dangerous
diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs
index ca67c8c897..181a93f0a3 100644
--- a/ghc/compiler/reader/Lex.lhs
+++ b/ghc/compiler/reader/Lex.lhs
@@ -753,8 +753,8 @@ ifaceKeywordsFM = listToUFM $
,("declarations_", ITdeclarations)
,("pragmas_", ITpragmas)
,("forall_", ITforall)
- ,("U_", ITunfold False)
- ,("U!_", ITunfold True)
+ ,("u_", ITunfold False)
+ ,("U_", ITunfold True)
,("A_", ITarity)
,("coerce_in_", ITcoerce_in)
,("coerce_out_", ITcoerce_out)
diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index bbbd9d5b4f..c7d3313126 100644
--- a/ghc/compiler/simplCore/SimplCase.lhs
+++ b/ghc/compiler/simplCore/SimplCase.lhs
@@ -43,8 +43,8 @@ Float let out of case.
\begin{code}
simplCase :: SimplEnv
- -> InExpr -- Scrutinee
- -> InAlts -- Alternatives
+ -> InExpr -- Scrutinee
+ -> (SubstEnvs, InAlts) -- Alternatives, and their static environment
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
-> OutType -- Type of result expression
-> SmplM OutExpr
@@ -99,27 +99,30 @@ All of this works equally well if the outer case has multiple rhss.
\begin{code}
-simplCase env (Case inner_scrut inner_alts) outer_alts rhs_c result_ty
+simplCase env (Case inner_scrut inner_alts) (subst_envs, outer_alts) rhs_c result_ty
| switchIsSet env SimplCaseOfCase
= -- Ha! Do case-of-case
tick CaseOfCase `thenSmpl_`
if no_need_to_bind_large_alts
then
- simplCase env inner_scrut inner_alts
- (\env rhs -> simplCase env rhs outer_alts rhs_c result_ty) result_ty
+ simplCase env inner_scrut (getSubstEnvs env, inner_alts)
+ (\env' rhs -> simplCase env' rhs (subst_envs, outer_alts) rhs_c result_ty)
+ result_ty
else
- bindLargeAlts env outer_alts rhs_c result_ty `thenSmpl` \ (extra_bindings, outer_alts') ->
+ bindLargeAlts env_alts outer_alts rhs_c result_ty `thenSmpl` \ (extra_bindings, outer_alts') ->
let
rhs_c' = \env rhs -> simplExpr env rhs [] result_ty
in
- simplCase env inner_scrut inner_alts
- (\env rhs -> simplCase env rhs outer_alts' rhs_c' result_ty)
+ simplCase env inner_scrut (getSubstEnvs env, inner_alts)
+ (\env rhs -> simplCase env rhs (emptySubstEnvs, outer_alts') rhs_c' result_ty)
result_ty
`thenSmpl` \ case_expr ->
returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr)
where
+ env_alts = setSubstEnvs env subst_envs
+
no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode ||
isSingleton (nonErrorRHSs inner_alts)
\end{code}
@@ -143,18 +146,20 @@ simplCase env scrut alts rhs_c result_ty
Finally the default case
\begin{code}
-simplCase env other_scrut alts rhs_c result_ty
- = simplTy env scrut_ty `appEager` \ scrut_ty' ->
- simplExpr env' other_scrut [] scrut_ty `thenSmpl` \ scrut' ->
- completeCase env scrut' alts rhs_c
+simplCase env other_scrut (subst_envs, alts) rhs_c result_ty
+ = simplTy env scrut_ty `appEager` \ scrut_ty' ->
+ simplExpr env_scrut other_scrut [] scrut_ty' `thenSmpl` \ scrut' ->
+ completeCase env_alts scrut' alts rhs_c
where
-- When simplifying the scrutinee of a complete case that
-- has no default alternative
- env' = case alts of
+ env_scrut = case alts of
AlgAlts _ NoDefault -> setCaseScrutinee env
PrimAlts _ NoDefault -> setCaseScrutinee env
other -> env
+ env_alts = setSubstEnvs env subst_envs
+
scrut_ty = coreExprType (unTagBinders other_scrut)
\end{code}
diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index 587406afad..8602354455 100644
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -7,6 +7,7 @@
module SimplEnv (
nullSimplEnv,
getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs, zapSubstEnvs,
+ emptySubstEnvs, getSubstEnvs,
bindTyVar, bindTyVars, simplTy,
@@ -28,7 +29,7 @@ module SimplEnv (
-- Types
SwitchChecker,
- SimplEnv,
+ SimplEnv, SubstEnvs,
UnfoldConApp,
SubstInfo(..),
@@ -154,6 +155,8 @@ type SimplValEnv = (IdEnv StuffAboutId, -- Domain includes *all* in-scope
-- Ids in the domain of the substitution are *not* in scope;
-- they *must* be substituted for the given OutArg
+type SubstEnvs = (TyVarEnv Type, IdEnv SubstInfo)
+
data SubstInfo
= SubstVar OutId -- The Id maps to an already-substituted atom
| SubstLit Literal -- ...ditto literal
@@ -204,9 +207,22 @@ setIdEnv :: SimplEnv -> SimplValEnv -> SimplEnv
setIdEnv (SimplEnv chkr encl_cc ty_env _ con_apps) id_env
= SimplEnv chkr encl_cc ty_env id_env con_apps
-setSubstEnvs :: SimplEnv -> TyVarEnv Type -> IdEnv SubstInfo -> SimplEnv
+getSubstEnvs :: SimplEnv -> SubstEnvs
+getSubstEnvs (SimplEnv _ _ (_, ty_subst) (_, id_subst) _) = (ty_subst, id_subst)
+
+emptySubstEnvs :: SubstEnvs
+emptySubstEnvs = (emptyTyVarEnv, nullIdEnv)
+
+setSubstEnvs :: SimplEnv -> SubstEnvs -> SimplEnv
setSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
- ty_subst id_subst
+ (ty_subst, id_subst)
+ = SimplEnv chkr encl_cc (in_scope_tyvars, ty_subst) (in_scope_ids, id_subst) con_apps
+
+combineEnvs :: SimplEnv -- Get substitution from here
+ -> SimplEnv -- Get in-scope info from here
+ -> SimplEnv
+combineEnvs (SimplEnv _ _ (_, ty_subst) (_, id_subst) _)
+ (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps)
= SimplEnv chkr encl_cc (in_scope_tyvars, ty_subst) (in_scope_ids, id_subst) con_apps
zapSubstEnvs :: SimplEnv -> SimplEnv
diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs
index b1d6664f63..7ed82def06 100644
--- a/ghc/compiler/simplCore/SimplVar.lhs
+++ b/ghc/compiler/simplCore/SimplVar.lhs
@@ -186,7 +186,7 @@ simplBinder env (id, occ_info)
#if DEBUG
-- I reckon the empty-env thing should catch
-- most no-free-tyvars things, so this test should be redundant
- (if idHasNoFreeTyVars id then pprTrace "applyEnvsToId" (ppr id) else (\x -> x))
+-- (if idHasNoFreeTyVars id then pprTrace "applyEnvsToId" (ppr id) else (\x -> x))
#endif
(let
-- id1 has its type zapped
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 8bde138524..03c9495dd2 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -250,7 +250,7 @@ simplExpr env (Var var) args result_ty
= case lookupIdSubst env var of
Just (SubstExpr ty_subst id_subst expr)
- -> simplExpr (setSubstEnvs env ty_subst id_subst) expr args result_ty
+ -> simplExpr (setSubstEnvs env (ty_subst, id_subst)) expr args result_ty
Just (SubstLit lit) -- A boring old literal
-> ASSERT( null args )
@@ -398,7 +398,10 @@ Case expressions
\begin{code}
simplExpr env expr@(Case scrut alts) args result_ty
- = simplCase env scrut alts (\env rhs -> simplExpr env rhs args result_ty) result_ty
+ = simplCase env scrut
+ (getSubstEnvs env, alts)
+ (\env rhs -> simplExpr env rhs args result_ty)
+ result_ty
\end{code}
@@ -709,7 +712,9 @@ simplValLam env expr min_no_of_args expr_ty
\begin{code}
-- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
simplCoerce env coercion ty expr@(Case scrut alts) args result_ty
- = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args result_ty) result_ty
+ = simplCase env scrut (getSubstEnvs env, alts)
+ (\env rhs -> simplCoerce env coercion ty rhs args result_ty)
+ result_ty
-- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
simplCoerce env coercion ty (Let bind body) args result_ty
@@ -904,7 +909,7 @@ simplNonRec env binder@(id,_) rhs body_c body_ty
-- we can't trivially do let-to-case (because there may be some unboxed
-- things bound in letrecs that aren't really recursive).
| isUnpointedType rhs_ty && not rhs_is_whnf
- = simplCase env rhs (PrimAlts [] (BindDefault binder (Var id)))
+ = simplCase env rhs (getSubstEnvs env, PrimAlts [] (BindDefault binder (Var id)))
(\env rhs -> complete_bind env rhs) body_ty
-- Try let-to-case; see notes below about let-to-case
@@ -918,7 +923,7 @@ simplNonRec env binder@(id,_) rhs body_c body_ty
-- the end of simplification.
)
= tick Let2Case `thenSmpl_`
- simplCase env rhs (AlgAlts [] (BindDefault binder (Var id)))
+ simplCase env rhs (getSubstEnvs env, AlgAlts [] (BindDefault binder (Var id)))
(\env rhs -> complete_bind env rhs) body_ty
-- OLD COMMENT: [now the new RHS is only "x" so there's less worry]
-- NB: it's tidier to call complete_bind not simpl_bind, else
@@ -946,14 +951,15 @@ simplNonRec env binder@(id,_) rhs body_c body_ty
-- First, bind large let-body if necessary
if ok_to_dup || isSingleton (nonErrorRHSs alts)
then
- simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
+ simplCase env scrut (getSubstEnvs env, alts)
+ (\env rhs -> simpl_bind env rhs) body_ty
else
bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
let
body_c' = \env -> simplExpr env new_body [] body_ty
case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty
in
- simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
+ simplCase env scrut (getSubstEnvs env, alts) case_c body_ty `thenSmpl` \ case_expr ->
returnSmpl (Let extra_binding case_expr)
-- None of the above; simplify rhs and tidy up
diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index ab4edecf4f..6c6f9d24bf 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -709,8 +709,8 @@ Hence, the invariant is this:
\begin{code}
specProgram :: UniqSupply -> [CoreBinding] -> [CoreBinding]
specProgram us binds
- = initSM us (go binds `thenSM` \ (binds', _) ->
- returnSM binds'
+ = initSM us (go binds `thenSM` \ (binds', uds') ->
+ returnSM (dumpAllDictBinds uds' binds')
)
where
go [] = returnSM ([], emptyUDs)
@@ -1064,6 +1064,11 @@ mkDB dict rhs = (dict, rhs, db_ftvs, db_fvs)
addDictBind uds dict rhs = uds { dict_binds = mkDB dict rhs `consBag` dict_binds uds }
+dumpAllDictBinds (MkUD {dict_binds = dbs}) binds
+ = foldrBag add binds dbs
+ where
+ add (dict,rhs,_,_) binds = NonRec dict rhs : binds
+
dumpUDs :: [CoreBinder]
-> UsageDetails -> CoreExpr
-> (UsageDetails, CoreExpr)
@@ -1174,9 +1179,11 @@ instantiateDictRhs ty_env id_env rhs
go (Var v) = Var (lookupId id_env v)
go (Lit l) = Lit l
go (Con con args) = Con con (map go_arg args)
+ go (Coerce c t e) = Coerce c (instantiateTy ty_env t) (go e)
go (Case e alts) = Case (go e) alts -- See comment below re alts
go other = pprPanic "instantiateDictRhs" (ppr rhs)
+
dictRhsFVs :: CoreExpr -> IdSet
-- Cheapo function for simple RHSs
dictRhsFVs e
@@ -1187,6 +1194,7 @@ dictRhsFVs e
go (Var v) = unitIdSet v
go (Lit l) = emptyIdSet
go (Con _ args) = mkIdSet [id | VarArg id <- args]
+ go (Coerce _ _ e) = go e
go (Case e _) = go e -- Claim: no free dictionaries in the alternatives
-- These case expressions are of the form
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 36451450c5..7c6e6e5e9e 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -154,8 +154,9 @@ import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
)
import PprType ( pprConstraint )
import TysWiredIn ( unitTy )
-import TyVar ( intersectTyVarSets, unionManyTyVarSets,
- isEmptyTyVarSet, zipTyVarEnv, emptyTyVarEnv
+import TyVar ( intersectTyVarSets, unionManyTyVarSets, minusTyVarSet,
+ isEmptyTyVarSet, tyVarSetToList,
+ zipTyVarEnv, emptyTyVarEnv
)
import FiniteMap
import BasicTypes ( TopLevelFlag(..) )
@@ -200,8 +201,23 @@ tcSimplify str top_lvl local_tvs wanted_lie
checkTc (null cant_generalise)
(genCantGenErr cant_generalise) `thenTc_`
- -- Finished
- returnTc (mkLIE frees, binds, mkLIE irreds)
+ -- Check for ambiguous insts.
+ -- You might think these can't happen (I did) because an ambiguous
+ -- inst like (Eq a) will get tossed out with "frees", and eventually
+ -- dealt with by tcSimplifyTop.
+ -- But we can get stuck with
+ -- C a b
+ -- where "a" is one of the local_tvs, but "b" is unconstrained.
+ -- Then we must yell about the ambiguous b
+ let
+ (irreds', bad_guys) = partition (isEmptyTyVarSet . ambig_tv_fn) irreds
+ ambig_tv_fn dict = tyVarsOfInst dict `minusTyVarSet` local_tvs
+ in
+ addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_`
+
+
+ -- Finished
+ returnTc (mkLIE frees, binds, mkLIE irreds')
where
wanteds = bagToList wanted_lie
@@ -865,7 +881,7 @@ tcSimplifyTop wanted_lie
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
complain d | isEmptyTyVarSet (tyVarsOfInst d) = addTopInstanceErr d
- | otherwise = addAmbigErr [d]
+ | otherwise = addAmbigErr tyVarsOfInst d
get_tv d = case getDictClassTys d of
(clas, [ty]) -> getTyVar "tcSimplifyTop" ty
@@ -913,7 +929,7 @@ disambigGroup dicts
in
-- See if any default works, and if so bind the type variable to it
-- If not, add an AmbigErr
- recoverTc (addAmbigErr dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $
+ recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $
try_default default_tys `thenTc` \ chosen_default_ty ->
@@ -932,10 +948,11 @@ disambigGroup dicts
returnTc EmptyMonoBinds
| otherwise -- No defaults
- = addAmbigErr dicts `thenNF_Tc_`
+ = complain dicts `thenNF_Tc_`
returnTc EmptyMonoBinds
where
+ complain = addAmbigErrs tyVarsOfInst
try_me inst = ReduceMe AddToIrreds -- This reduce should not fail
tyvar = get_tv (head dicts) -- Should be non-empty
classes = map get_clas dicts
@@ -955,10 +972,16 @@ genCantGenErr insts -- Can't generalise these Insts
nest 4 (pprInstsInFull insts)
]
-addAmbigErr dicts
- = tcAddSrcLoc (instLoc (head dicts)) $
- addErrTc (sep [text "Cannot resolve the ambiguous context" <+> pprInsts dicts,
- nest 4 (pprInstsInFull dicts)])
+addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
+
+addAmbigErr ambig_tv_fn dict
+ = tcAddSrcLoc (instLoc dict) $
+ addErrTc (sep [text "Ambiguous type variable(s)",
+ hsep (punctuate comma (map (quotes . ppr) ambig_tvs)),
+ nest 4 (text "in the constraint" <+> quotes (pprInst dict)),
+ nest 4 (pprOrigin dict)])
+ where
+ ambig_tvs = tyVarSetToList (ambig_tv_fn dict)
-- Used for top-level irreducibles
addTopInstanceErr dict
View Lorry Controller Status