X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=2141e078cd649e91ecb53eac7e18b8ee7111041c;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hp=5f00a8e9e7c939dac3d22317591fb1f8890f9ac9;hpb=12899612693163154531da3285ec99c1c8ca2226;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 5f00a8e..2141e07 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -22,13 +22,14 @@ import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp, unTagBinders, squashableDictishCcExpr ) import Id ( idType, idWantsToBeINLINEd, + externallyVisibleId, getIdDemandInfo, addIdDemandInfo, GenId{-instance NamedThing-} ) import IdInfo ( willBeDemanded, DemandInfo ) import Literal ( isNoRepLit ) import Maybes ( maybeToBool ) -import Name ( isLocallyDefined ) +--import Name ( isExported ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) import Pretty ( ppAbove ) @@ -193,8 +194,8 @@ simplTopBinds env [] = returnSmpl [] simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds) = -- No cloning necessary at top level -- Process the binding - simplRhsExpr env binder rhs `thenSmpl` \ rhs' -> - completeNonRec env binder rhs' `thenSmpl` \ (new_env, binds1') -> + simplRhsExpr env binder rhs `thenSmpl` \ rhs' -> + completeNonRec env binder in_id rhs' `thenSmpl` \ (new_env, binds1') -> -- Process the other bindings simplTopBinds new_env binds `thenSmpl` \ binds2' -> @@ -733,10 +734,17 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty simpl_bind env rhs | will_be_demanded && try_let_to_case && type_ok_for_let_to_case rhs_ty && - rhs_is_whnf -- note: WHNF, but not bottom, (comment below) + not rhs_is_whnf -- note: WHNF, but not bottom, (comment below) = tick Let2Case `thenSmpl_` mkIdentityAlts rhs_ty `thenSmpl` \ id_alts -> - simplCase env rhs id_alts (\env rhs -> simpl_bind env rhs) body_ty + simplCase env rhs id_alts (\env rhs -> complete_bind env rhs) body_ty + -- NB: it's tidier to call complete_bind not simpl_bind, else + -- we nearly end up in a loop. Consider: + -- let x = rhs in b + -- ==> case rhs of (p,q) -> let x=(p,q) in b + -- This effectively what the above simplCase call does. + -- Now, the inner let is a let-to-case target again! Actually, since + -- the RHS is in WHNF it won't happen, but it's a close thing! -- Try let-from-let simpl_bind env (Let bind rhs) | let_floating_ok @@ -763,10 +771,13 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty returnSmpl (Let extra_binding case_expr) -- None of the above; simplify rhs and tidy up - simpl_bind env rhs - = simplRhsExpr env binder rhs `thenSmpl` \ rhs' -> - completeNonRec env binder rhs' `thenSmpl` \ (new_env, binds) -> - body_c new_env `thenSmpl` \ body' -> + simpl_bind env rhs = complete_bind env rhs + + complete_bind env rhs + = simplRhsExpr env binder rhs `thenSmpl` \ rhs' -> + cloneId env binder `thenSmpl` \ new_id -> + completeNonRec env binder new_id rhs' `thenSmpl` \ (new_env, binds) -> + body_c new_env `thenSmpl` \ body' -> returnSmpl (mkCoLetsAny binds body') @@ -951,7 +962,7 @@ simplBind env (Rec pairs) body_c body_ty let env_w_clones = extendIdEnvWithClones env binders ids' in - simplRecursiveGroup env ids' floated_pairs `thenSmpl` \ (binding, new_env) -> + simplRecursiveGroup env_w_clones ids' floated_pairs `thenSmpl` \ (binding, new_env) -> body_c new_env `thenSmpl` \ body' -> @@ -989,7 +1000,8 @@ simplBind env (Rec pairs) body_c body_ty simplRecursiveGroup env new_ids pairs = -- Add unfoldings to the new_ids corresponding to their RHS let - occs = [occ | ((_,occ), _) <- pairs] + binders = map fst pairs + occs = map snd binders new_ids_w_pairs = zipEqual "simplRecGp" new_ids pairs rhs_env = foldl extendEnvForRecBinding env new_ids_w_pairs @@ -998,11 +1010,12 @@ simplRecursiveGroup env new_ids pairs mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss -> let - new_pairs = zipEqual "simplRecGp" new_ids new_rhss + new_pairs = zipEqual "simplRecGp" new_ids new_rhss occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs - new_env = foldl (\env (occ_info,(new_id,new_rhs)) -> - extendEnvGivenBinding env occ_info new_id new_rhs) - env occs_w_new_pairs + new_env = foldl add_binding env occs_w_new_pairs + + add_binding env (occ_info,(new_id,new_rhs)) + = extendEnvGivenBinding env occ_info new_id new_rhs in returnSmpl (Rec new_pairs, new_env) \end{code} @@ -1049,55 +1062,64 @@ x. That's just what completeLetBinding does. \begin{code} - -- Sigh: rather disgusting case for coercions. We want to - -- ensure that all let-bound Coerces have atomic bodies, so - -- they can freely be inlined. -completeNonRec env binder@(_,occ_info) (Coerce coercion ty rhs) - = (case rhs of - Var v -> returnSmpl (env, [], rhs) - Lit l -> returnSmpl (env, [], rhs) - other -> newId (coreExprType rhs) `thenSmpl` \ inner_id -> - completeNonRec env - (inner_id, dangerousArgOcc) rhs `thenSmpl` \ (env1, extra_bind) -> - -- Dangerous occ because, like constructor args, - -- it can be duplicated easily - let - atomic_rhs = case lookupId env1 inner_id of - LitArg l -> Lit l - VarArg v -> Var v - in - returnSmpl (env1, extra_bind, atomic_rhs) - ) `thenSmpl` \ (env1, extra_bind, atomic_rhs) -> - -- Tiresome to do all this, but we must treat the lit/var cases specially - -- or we get a tick for atomic rhs when effectively it's a no-op. - - cloneId env1 binder `thenSmpl` \ new_id -> - let - new_rhs = Coerce coercion ty atomic_rhs - env2 = extendIdEnvWithClone env1 binder new_id - new_env = extendEnvGivenBinding env2 occ_info new_id new_rhs - in - returnSmpl (new_env, extra_bind ++ [NonRec new_id new_rhs]) - -completeNonRec env binder new_rhs - -- See if RHS is an atom, or a reusable constructor - | maybeToBool maybe_atomic_rhs - = let - new_env = extendIdEnvWithAtom env binder rhs_atom - in - tick atom_tick_type `thenSmpl_` - returnSmpl (new_env, []) - where - maybe_atomic_rhs = exprToAtom env new_rhs - Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs - -completeNonRec env binder@(_,occ_info) new_rhs - = cloneId env binder `thenSmpl` \ new_id -> + -- We want to ensure that all let-bound Coerces have + -- atomic bodies, so they can freely be inlined. +completeNonRec env binder new_id (Coerce coercion ty rhs) + | not (is_atomic rhs) + = newId (coreExprType rhs) `thenSmpl` \ inner_id -> + completeNonRec env + (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) -> + -- Dangerous occ because, like constructor args, + -- it can be duplicated easily let - env1 = extendIdEnvWithClone env binder new_id - new_env = extendEnvGivenBinding env1 occ_info new_id new_rhs + atomic_rhs = case lookupId env1 inner_id of + LitArg l -> Lit l + VarArg v -> Var v in - returnSmpl (new_env, [NonRec new_id new_rhs]) + completeNonRec env1 binder new_id + (Coerce coercion ty atomic_rhs) `thenSmpl` \ (env2, binds2) -> + + returnSmpl (env2, binds1 ++ binds2) + where + is_atomic (Var v) = True + is_atomic (Lit l) = not (isNoRepLit l) + is_atomic other = False + + -- Atomic right-hand sides. + -- We used to have a "tick AtomicRhs" in here, but it causes more trouble + -- than it's worth. For a top-level binding a = b, where a is exported, + -- we can't drop the binding, so we get repeated AtomicRhs ticks +completeNonRec env binder new_id rhs@(Var v) + = returnSmpl (extendIdEnvWithAtom env binder (VarArg v), [NonRec new_id rhs]) + +completeNonRec env binder new_id rhs@(Lit lit) + | not (isNoRepLit lit) + = returnSmpl (extendIdEnvWithAtom env binder (LitArg lit), [NonRec new_id rhs]) + + -- Right hand sides that are constructors + -- let v = C args + -- in + --- ...(let w = C same-args in ...)... + -- Then use v instead of w. This may save + -- re-constructing an existing constructor. +completeNonRec env binder new_id rhs@(Con con con_args) + | switchIsSet env SimplReuseCon && + maybeToBool maybe_existing_con && + not (externallyVisibleId new_id) -- Don't bother for exported things + -- because we won't be able to drop + -- its binding. + = tick ConReused `thenSmpl_` + returnSmpl (extendIdEnvWithAtom env binder (VarArg it), [NonRec new_id rhs]) + where + maybe_existing_con = lookForConstructor env con con_args + Just it = maybe_existing_con + + -- Default case +completeNonRec env binder@(id,occ_info) new_id rhs + = returnSmpl (new_env, [NonRec new_id rhs]) + where + env1 = extendIdEnvWithClone env binder new_id + new_env = extendEnvGivenBinding env1 occ_info new_id rhs \end{code} %************************************************************************ @@ -1114,31 +1136,6 @@ simplArg env (TyArg ty) = TyArg (simplTy env ty) simplArg env (VarArg id) = lookupId env id \end{code} - -\begin{code} -exprToAtom env (Var var) - = Just (VarArg var, AtomicRhs) - -exprToAtom env (Lit lit) - | not (isNoRepLit lit) - = Just (LitArg lit, AtomicRhs) - -exprToAtom env (Con con con_args) - | switchIsSet env SimplReuseCon - -- Look out for - -- let v = C args - -- in - --- ...(let w = C same-args in ...)... - -- Then use v instead of w. This may save - -- re-constructing an existing constructor. - = case (lookForConstructor env con con_args) of - Nothing -> Nothing - Just var -> Just (VarArg var, ConReused) - -exprToAtom env other - = Nothing -\end{code} - %************************************************************************ %* * \subsection[Simplify-quickies]{Some local help functions}