X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=9bc78267c09003cd12ddde3c39057fe68e444af0;hb=58e45ee86bbda3f24a4caf41c0aea7a6b787367e;hp=95aa89e4c0d67203eeeb97204604c824ffe35a08;hpb=3ceff7a48281bfb6145abb174ad5a46e59f83909;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 95aa89e..9bc7826 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -4,6 +4,13 @@ \section[SimplUtils]{The simplifier utilities} \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module SimplUtils ( -- Rebuilding mkLam, mkCase, prepareAlts, bindCaseBndr, @@ -15,7 +22,7 @@ module SimplUtils ( -- The continuation type SimplCont(..), DupFlag(..), LetRhsFlag(..), contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, - countValArgs, countArgs, + countValArgs, countArgs, splitInlineCont, mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhsOrArg, interestingCallContext, interestingArgContext, @@ -39,9 +46,11 @@ import CoreUnfold import MkId import Name import Id +import Var ( isCoVar ) import NewDemand import SimplMonad -import Type +import Type ( Type, funArgTy, mkForAllTys, mkTyVarTys, + splitTyConApp_maybe, tyConAppArgs ) import TyCon import DataCon import Unify ( dataConCannotMatch ) @@ -153,10 +162,11 @@ mkLazyArgStop ty has_rules = Stop ty AnArg (canUpdateInPlace ty || has_rules) mkRhsStop :: OutType -> SimplCont mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty) -contIsRhsOrArg (Stop {}) = True -contIsRhsOrArg (StrictBind {}) = True -contIsRhsOrArg (StrictArg {}) = True -contIsRhsOrArg other = False +------------------- +contIsRhsOrArg (Stop {}) = True +contIsRhsOrArg (StrictBind {}) = True +contIsRhsOrArg (StrictArg {}) = True +contIsRhsOrArg other = False ------------------- contIsDupable :: SimplCont -> Bool @@ -203,6 +213,26 @@ dropArgs :: Int -> SimplCont -> SimplCont dropArgs 0 cont = cont dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont dropArgs n other = pprPanic "dropArgs" (ppr n <+> ppr other) + +-------------------- +splitInlineCont :: SimplCont -> Maybe (SimplCont, SimplCont) +-- Returns Nothing if the continuation should dissolve an InlineMe Note +-- Return Just (c1,c2) otherwise, +-- where c1 is the continuation to put inside the InlineMe +-- and c2 outside + +-- Example: (__inline_me__ (/\a. e)) ty +-- Here we want to do the beta-redex without dissolving the InlineMe +-- See test simpl017 (and Trac #1627) for a good example of why this is important + +splitInlineCont (ApplyTo dup (Type ty) se c) + | Just (c1, c2) <- splitInlineCont c = Just (ApplyTo dup (Type ty) se c1, c2) +splitInlineCont cont@(Stop ty _ _) = Just (mkBoringStop ty, cont) +splitInlineCont cont@(StrictBind bndr _ _ se _) = Just (mkBoringStop (substTy se (idType bndr)), cont) +splitInlineCont cont@(StrictArg _ fun_ty _ _) = Just (mkBoringStop (funArgTy fun_ty), cont) +splitInlineCont other = Nothing + -- NB: the calculation of the type for mkBoringStop is an annoying + -- duplication of the same calucation in mkDupableCont \end{code} @@ -1025,23 +1055,27 @@ it is guarded by the doFloatFromRhs call in simplLazyBind. \begin{code} abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr) -abstractFloats tvs body_env body +abstractFloats main_tvs body_env body = ASSERT( notNull body_floats ) do { (subst, float_binds) <- mapAccumLSmpl abstract empty_subst body_floats ; return (float_binds, CoreSubst.substExpr subst body) } where - main_tv_set = mkVarSet tvs + main_tv_set = mkVarSet main_tvs body_floats = getFloats body_env empty_subst = CoreSubst.mkEmptySubst (seInScope body_env) abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind) abstract subst (NonRec id rhs) = do { (poly_id, poly_app) <- mk_poly tvs_here id - ; let poly_rhs = mkLams tvs_here (CoreSubst.substExpr subst rhs) + ; let poly_rhs = mkLams tvs_here rhs' subst' = CoreSubst.extendIdSubst subst id poly_app ; return (subst', (NonRec poly_id poly_rhs)) } where - tvs_here = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs) + rhs' = CoreSubst.substExpr subst rhs + tvs_here | any isCoVar main_tvs = main_tvs -- Note [Abstract over coercions] + | otherwise + = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs') + -- Abstract only over the type variables free in the rhs -- wrt which the new binding is abstracted. But the naive -- approach of abstract wrt the tyvars free in the Id's type @@ -1065,12 +1099,20 @@ abstractFloats tvs body_env body ; return (subst', Rec (poly_ids `zip` poly_rhss)) } where (ids,rhss) = unzip prs - - tvs_here = varSetElems (main_tv_set `intersectVarSet` bind_ftvs) - bind_ftvs = exprsSomeFreeVars isTyVar rhss `unionVarSet` tyVarsOfTypes (map idType ids) - -- Also nb that we must take the tyvars of the Id's type too: + -- For a recursive group, it's a bit of a pain to work out the minimal + -- set of tyvars over which to abstract: + -- /\ a b c. let x = ...a... in + -- letrec { p = ...x...q... + -- q = .....p...b... } in + -- ... + -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted + -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'. + -- Since it's a pain, we just use the whole set, which is always safe + -- + -- If you ever want to be more selective, remember this bizarre case too: -- x::a = x - -- Bizarre, I know + -- Here, we must abstract 'x' over 'a'. + tvs_here = main_tvs mk_poly tvs_here var = do { uniq <- getUniqueSmpl @@ -1092,6 +1134,13 @@ abstractFloats tvs body_env body -- pinned on x. \end{code} +Note [Abstract over coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the +type variable a. Rather than sort this mess out, we simply bale out and abstract +wrt all the type variables if any of them are coercion variables. + + Historical note: if you use let-bindings instead of a substitution, beware of this: -- Suppose we start with: @@ -1182,8 +1231,8 @@ have to check that r doesn't mention the variables bound by the pattern in each alternative, so the binder-info is rather useful. \begin{code} -prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) -prepareAlts scrut case_bndr' alts +prepareAlts :: SimplEnv -> OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) +prepareAlts env scrut case_bndr' alts = do { dflags <- getDOptsSmpl ; alts <- combineIdenticalAlts case_bndr' alts @@ -1194,7 +1243,7 @@ prepareAlts scrut case_bndr' alts -- EITHER by the context, -- OR by a non-DEFAULT branch in this case expression. - ; default_alts <- prepareDefault dflags scrut case_bndr' mb_tc_app + ; default_alts <- prepareDefault dflags env case_bndr' mb_tc_app imposs_deflt_cons maybe_deflt ; let trimmed_alts = filterOut impossible_alt alts_wo_default @@ -1240,7 +1289,7 @@ combineIdenticalAlts case_bndr alts = return alts -- Prepare the default alternative ------------------------------------------------------------------------- prepareDefault :: DynFlags - -> OutExpr -- Scrutinee + -> SimplEnv -> OutId -- Case binder; need just for its type. Note that as an -- OutId, it has maximum information; this is important. -- Test simpl013 is an example @@ -1252,10 +1301,16 @@ prepareDefault :: DynFlags -- And becuase case-merging can cause many to show up ------- Merge nested cases ---------- -prepareDefault dflags scrut outer_bndr bndr_ty imposs_cons (Just deflt_rhs) +prepareDefault dflags env outer_bndr bndr_ty imposs_cons (Just deflt_rhs) | dopt Opt_CaseMerge dflags - , Case (Var scrut_var) inner_bndr _ inner_alts <- deflt_rhs - , scruting_same_var scrut_var + , Case (Var inner_scrut_var) inner_bndr _ inner_alts <- deflt_rhs + , DoneId inner_scrut_var' <- substId env inner_scrut_var + -- Remember, inner_scrut_var is an InId, but outer_bndr is an OutId + , inner_scrut_var' == outer_bndr + -- NB: the substId means that if the outer scrutinee was a + -- variable, and inner scrutinee is the same variable, + -- then inner_scrut_var' will be outer_bndr + -- via the magic of simplCaseBinder = do { tick (CaseMerge outer_bndr) ; let munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs @@ -1275,17 +1330,10 @@ prepareDefault dflags scrut outer_bndr bndr_ty imposs_cons (Just deflt_rhs) -- mkCase applied to them, so they won't have a case in their default -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr -- in munge_rhs may put a case into the DEFAULT branch! - where - -- We are scrutinising the same variable if it's - -- the outer case-binder, or if the outer case scrutinises a variable - -- (and it's the same). Testing both allows us not to replace the - -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder). - scruting_same_var = case scrut of - Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut - other -> \ v -> v == outer_bndr + --------- Fill in known constructor ----------- -prepareDefault dflags scrut case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs) +prepareDefault dflags env case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs) | -- This branch handles the case where we are -- scrutinisng an algebraic data type isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. @@ -1319,10 +1367,10 @@ prepareDefault dflags scrut case_bndr (Just (tycon, inst_tys)) imposs_cons (Just two_or_more -> return [(DEFAULT, [], deflt_rhs)] --------- Catch-all cases ----------- -prepareDefault dflags scrut case_bndr bndr_ty imposs_cons (Just deflt_rhs) +prepareDefault dflags env case_bndr bndr_ty imposs_cons (Just deflt_rhs) = return [(DEFAULT, [], deflt_rhs)] -prepareDefault dflags scrut case_bndr bndr_ty imposs_cons Nothing +prepareDefault dflags env case_bndr bndr_ty imposs_cons Nothing = return [] -- No default branch \end{code}