X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=6739aafc6f3a9b25282ad3e0a376cf6a5a998f32;hb=6afe26f227697a58e349556d1977ca8a5e2e4e85;hp=cff659d55696d563f73b9c8a6f2c6daefe1ba78e;hpb=87e82c15b1ab2eb3dd37c681f6615ec47b476f9f;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index cff659d..6739aaf 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -56,7 +56,9 @@ import Unify ( dataConCannotMatch ) import VarSet import BasicTypes import Util +import MonadUtils import Outputable + import List( nub ) \end{code} @@ -95,10 +97,8 @@ data SimplCont Bool -- True <=> There is something interesting about -- the context, and hence the inliner -- should be a bit keener (see interestingCallContext) - -- Two cases: - -- (a) This is the RHS of a thunk whose type suggests - -- that update-in-place would be possible - -- (b) This is an argument of a function that has RULES + -- Specifically: + -- This is an argument of a function that has RULES -- Inlining the call might allow the rule to fire | CoerceIt -- C `cast` co @@ -156,10 +156,10 @@ mkBoringStop :: OutType -> SimplCont mkBoringStop ty = Stop ty AnArg False mkLazyArgStop :: OutType -> Bool -> SimplCont -mkLazyArgStop ty has_rules = Stop ty AnArg (canUpdateInPlace ty || has_rules) +mkLazyArgStop ty has_rules = Stop ty AnArg has_rules mkRhsStop :: OutType -> SimplCont -mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty) +mkRhsStop ty = Stop ty AnRhs False ------------------- contIsRhsOrArg (Stop {}) = True @@ -400,27 +400,6 @@ interestingArgContext fn call_cont go (StrictBind {}) = False -- ?? go (CoerceIt _ c) = go c go (Stop _ _ interesting) = interesting - -------------------- -canUpdateInPlace :: Type -> Bool --- Consider let x = in ... --- If returns an explicit constructor, we might be able --- to do update in place. So we treat even a thunk RHS context --- as interesting if update in place is possible. We approximate --- this by seeing if the type has a single constructor with a --- small arity. But arity zero isn't good -- we share the single copy --- for that case, so no point in sharing. - -canUpdateInPlace ty - | not opt_UF_UpdateInPlace = False - | otherwise - = case splitTyConApp_maybe ty of - Nothing -> False - Just (tycon, _) -> case tyConDataCons_maybe tycon of - Just [dc] -> arity == 1 || arity == 2 - where - arity = dataConRepArity dc - other -> False \end{code} @@ -829,7 +808,7 @@ mkLam bndrs body ; return (mkLams bndrs body') } | otherwise - = returnSmpl (mkLams bndrs body) + = return (mkLams bndrs body) \end{code} Note [Casts and lambdas] @@ -875,8 +854,8 @@ because the latter is not well-kinded. -- if this is indeed a right-hand side; otherwise -- we end up floating the thing out, only for float-in -- to float it right back in again! - = tryRhsTyLam env bndrs body `thenSmpl` \ (floats, body') -> - returnSmpl (floats, mkLams bndrs body') + = do (floats, body') <- tryRhsTyLam env bndrs body + return (floats, mkLams bndrs body') -} @@ -998,9 +977,9 @@ actually computing the expansion. \begin{code} tryEtaExpansion :: DynFlags -> OutExpr -> SimplM OutExpr -- There is at least one runtime binder in the binders -tryEtaExpansion dflags body - = getUniquesSmpl `thenSmpl` \ us -> - returnSmpl (etaExpand fun_arity us body (exprType body)) +tryEtaExpansion dflags body = do + us <- getUniquesM + return (etaExpand fun_arity us body (exprType body)) where fun_arity = exprEtaExpandArity dflags body \end{code} @@ -1092,7 +1071,7 @@ it is guarded by the doFloatFromRhs call in simplLazyBind. abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr) abstractFloats main_tvs body_env body = ASSERT( notNull body_floats ) - do { (subst, float_binds) <- mapAccumLSmpl abstract empty_subst body_floats + do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats ; return (float_binds, CoreSubst.substExpr subst body) } where main_tv_set = mkVarSet main_tvs @@ -1128,7 +1107,7 @@ abstractFloats main_tvs body_env body -- gives rise to problems. SLPJ June 98 abstract subst (Rec prs) - = do { (poly_ids, poly_apps) <- mapAndUnzipSmpl (mk_poly tvs_here) ids + = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps) poly_rhss = [mkLams tvs_here (CoreSubst.substExpr subst' rhs) | rhs <- rhss] ; return (subst', Rec (poly_ids `zip` poly_rhss)) } @@ -1150,7 +1129,7 @@ abstractFloats main_tvs body_env body tvs_here = main_tvs mk_poly tvs_here var - = do { uniq <- getUniqueSmpl + = do { uniq <- getUniqueM ; let poly_name = setNameUnique (idName var) uniq -- Keep same name poly_ty = mkForAllTys tvs_here (idType var) -- But new type of course poly_id = mkLocalId poly_name poly_ty @@ -1394,7 +1373,7 @@ prepareDefault dflags env case_bndr (Just (tycon, inst_tys)) imposs_cons (Just d [con] -> -- It matches exactly one constructor, so fill it in do { tick (FillInCaseDefault case_bndr) - ; us <- getUniquesSmpl + ; us <- getUniquesM ; let (ex_tvs, co_tvs, arg_ids) = dataConRepInstPat us con inst_tys ; return [(DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, deflt_rhs)] } @@ -1451,8 +1430,8 @@ mkCase scrut case_bndr ty [] mkCase scrut case_bndr ty alts -- Identity case | all identity_alt alts - = tick (CaseIdentity case_bndr) `thenSmpl_` - returnSmpl (re_cast scrut) + = do tick (CaseIdentity case_bndr) + return (re_cast scrut) where identity_alt (con, args, rhs) = check_eq con args (de_cast rhs) @@ -1485,7 +1464,7 @@ mkCase scrut case_bndr ty alts -- Identity case -------------------------------------------------- -- Catch-all -------------------------------------------------- -mkCase scrut bndr ty alts = returnSmpl (Case scrut bndr ty alts) +mkCase scrut bndr ty alts = return (Case scrut bndr ty alts) \end{code}