arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo,
bottomIsGuaranteed, workerExists,
)
+import PragmaInfo ( PragmaInfo(..) )
import CoreSyn ( CoreExpr, CoreBinding, GenCoreExpr, GenCoreBinding(..) )
import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding )
import FreeVars ( addExprFVs )
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
,("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)
\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
\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}
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}
module SimplEnv (
nullSimplEnv,
getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs, zapSubstEnvs,
+ emptySubstEnvs, getSubstEnvs,
bindTyVar, bindTyVars, simplTy,
-- Types
SwitchChecker,
- SimplEnv,
+ SimplEnv, SubstEnvs,
UnfoldConApp,
SubstInfo(..),
-- 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
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
#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
= 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 )
\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}
\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
-- 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
-- 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
-- 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
\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)
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)
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
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
)
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(..) )
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
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
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 ->
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
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
projects / ghc-hetmet.git / commitdiff