From 350263b7fc9352f7eecb1769fe1840b0e20c7e04 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 19 Mar 1998 17:44:52 +0000 Subject: [PATCH] [project @ 1998-03-19 17:44:26 by simonpj] Minor simplifier fixes --- ghc/compiler/main/MkIface.lhs | 8 +++++- ghc/compiler/reader/Lex.lhs | 4 +-- ghc/compiler/simplCore/SimplCase.lhs | 31 +++++++++++++--------- ghc/compiler/simplCore/SimplEnv.lhs | 22 +++++++++++++--- ghc/compiler/simplCore/SimplVar.lhs | 2 +- ghc/compiler/simplCore/Simplify.lhs | 20 +++++++++----- ghc/compiler/specialise/Specialise.lhs | 12 +++++++-- ghc/compiler/typecheck/TcSimplify.lhs | 45 ++++++++++++++++++++++++-------- 8 files changed, 104 insertions(+), 40 deletions(-) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 5b5c213..cc8dc37 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 ca67c8c..181a93f 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 bbbd9d5..c7d3313 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 587406a..8602354 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 b1d6664..7ed82de 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 8bde138..03c9495 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 ab4edec..6c6f9d2 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 3645145..7c6e6e5 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 -- 1.7.10.4