X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSat.lhs;h=9fdcc09a069b3b5c12ed7e8a3df6c0f7767cea31;hb=8d0e6c63640414fda69fe77c126f10128a90a5f3;hp=1b347d1b555e27232764d48768bda3f0a9a08956;hpb=05c41def95ec45bbe63d3c9ab0ba9e19648717e0;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreSat.lhs b/ghc/compiler/coreSyn/CoreSat.lhs index 1b347d1..9fdcc09 100644 --- a/ghc/compiler/coreSyn/CoreSat.lhs +++ b/ghc/compiler/coreSyn/CoreSat.lhs @@ -10,19 +10,22 @@ module CoreSat ( #include "HsVersions.h" -import CoreUtils -import CoreFVs -import CoreLint +import CoreUtils( exprIsTrivial, exprIsAtom, exprType, exprIsValue, etaExpand, exprArity ) +import CoreFVs ( exprFreeVars ) +import CoreLint ( endPass ) import CoreSyn -import Type -import Demand -import Var ( TyVar, setTyVarUnique ) +import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy, + isUnLiftedType, isUnboxedTupleType, repType, + uaUTy, usOnce, usMany, seqType ) +import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) ) +import Var ( Id, TyVar, setTyVarUnique ) import VarSet -import IdInfo -import Id -import PrimOp +import IdInfo ( IdFlavour(..) ) +import Id ( mkSysLocal, idType, idStrictness, idFlavour, idDemandInfo, idArity ) + import UniqSupply import Maybes +import OrdList import ErrUtils import CmdLineOpts import Outputable @@ -32,34 +35,45 @@ import Outputable -- Overview -- --------------------------------------------------------------------------- +MAJOR CONSTRAINT: + By the time this pass happens, we have spat out tidied Core into + the interface file, including all IdInfo. + + So we must not change the arity of any top-level function, + because we've already fixed it and put it out into the interface file. + Nor must we change a value (e.g. constructor) into a thunk. + + It's ok to introduce extra bindings, which don't appear in the + interface file. We don't put arity info on these extra bindings, + because they are never fully applied, so there's no chance of + compiling just-a-fast-entry point for them. + Most of the contents of this pass used to be in CoreToStg. The primary goals here are: -1. Get the program into "A-normal form". In particular: +1. Saturate constructor and primop applications. - f E ==> let x = E in f x - OR ==> case E of x -> f x +2. Convert to A-normal form: + * Use case for strict arguments: + f E ==> case E of x -> f x + (where f is strict) - if E is a non-trivial expression. - Which transformation is used depends on whether f is strict or not. - [Previously the transformation to case used to be done by the - simplifier, but it's better done here. It does mean that f needs - to have its strictness info correct!.] + * Use let for non-trivial lazy arguments + f E ==> let x = E in f x + (were f is lazy and x is non-trivial) -2. Similarly, convert any unboxed lets into cases. - [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form - right up to this point.] +3. Similarly, convert any unboxed lets into cases. + [I'm experimenting with leaving 'ok-for-speculation' + rhss in let-form right up to this point.] - This is all done modulo type applications and abstractions, so that - when type erasure is done for conversion to STG, we don't end up with - any trivial or useless bindings. - -3. Ensure that lambdas only occur as the RHS of a binding +4. Ensure that lambdas only occur as the RHS of a binding (The code generator can't deal with anything else.) -4. Saturate constructor and primop applications. - +This is all done modulo type applications and abstractions, so that +when type erasure is done for conversion to STG, we don't end up with +any trivial or useless bindings. + -- ----------------------------------------------------------------------------- @@ -71,7 +85,7 @@ coreSatPgm :: DynFlags -> [CoreBind] -> IO [CoreBind] coreSatPgm dflags binds = do showPass dflags "CoreSat" us <- mkSplitUniqSupply 's' - let new_binds = initUs_ us (coreSatBinds binds) + let new_binds = initUs_ us (coreSatTopBinds binds) endPass dflags "CoreSat" Opt_D_dump_sat new_binds coreSatExpr :: DynFlags -> CoreExpr -> IO CoreExpr @@ -80,66 +94,114 @@ coreSatExpr dflags expr us <- mkSplitUniqSupply 's' let new_expr = initUs_ us (coreSatAnExpr expr) dumpIfSet_dyn dflags Opt_D_dump_sat "Saturated/Normal form syntax:" - (ppr new_expr) + (ppr new_expr) return new_expr -- --------------------------------------------------------------------------- -- Dealing with bindings -- --------------------------------------------------------------------------- -data FloatingBind - = RecF [(Id, CoreExpr)] - | NonRecF Id - CoreExpr -- *Can* be a Lam - RhsDemand - [FloatingBind] - -coreSatBinds :: [CoreBind] -> UniqSM [CoreBind] -coreSatBinds [] = returnUs [] -coreSatBinds (b:bs) - = coreSatBind b `thenUs` \ float -> - coreSatBinds bs `thenUs` \ new_bs -> - case float of - NonRecF bndr rhs dem floats - -> ASSERT2( not (isStrictDem dem) && - not (isUnLiftedType (idType bndr)), - ppr b ) -- No top-level cases! - - mkBinds floats rhs `thenUs` \ new_rhs -> - returnUs (NonRec bndr new_rhs : new_bs) - -- Keep all the floats inside... - -- Some might be cases etc - -- We might want to revisit this decision - - RecF prs -> returnUs (Rec prs : new_bs) - -coreSatBind :: CoreBind -> UniqSM FloatingBind +data FloatingBind = FloatLet CoreBind + | FloatCase Id CoreExpr + +allLazy :: OrdList FloatingBind -> Bool +allLazy floats = foldOL check True floats + where + check (FloatLet _) y = y + check (FloatCase _ _) y = False + +coreSatTopBinds :: [CoreBind] -> UniqSM [CoreBind] +-- Very careful to preserve the arity of top-level functions +coreSatTopBinds [] = returnUs [] + +coreSatTopBinds (NonRec b r : binds) + = coreSatTopRhs b r `thenUs` \ (floats, r') -> + coreSatTopBinds binds `thenUs` \ binds' -> + returnUs (floats ++ NonRec b r' : binds') + +coreSatTopBinds (Rec prs : binds) + = mapAndUnzipUs do_pair prs `thenUs` \ (floats_s, prs') -> + coreSatTopBinds binds `thenUs` \ binds' -> + returnUs (Rec (flattenBinds (concat floats_s) ++ prs') : binds') + where + do_pair (b,r) = coreSatTopRhs b r `thenUs` \ (floats, r') -> + returnUs (floats, (b, r')) + +coreSatTopRhs :: Id -> CoreExpr -> UniqSM ([CoreBind], CoreExpr) +-- The trick here is that if we see +-- x = $wC p $wJust q +-- we want to transform to +-- sat = \a -> $wJust a +-- x = $wC p sat q +-- and NOT to +-- x = let sat = \a -> $wJust a in $wC p sat q +-- +-- The latter is bad because the thing was a value before, but +-- is a thunk now, and that's wrong because now x may need to +-- be in other bindings' SRTs. +-- This has to be right for recursive as well as non-recursive bindings +-- +-- Notice that it's right to give sat vanilla IdInfo; in particular NoCafRefs +-- +-- You might worry that arity might increase, thus +-- x = $wC a ==> x = \ b c -> $wC a b c +-- but the simpifier does eta expansion vigorously, so I don't think this +-- can occur. If it did, it would be a problem, because x's arity changes, +-- so we have an ASSERT to check. (I use WARN so we can see the output.) + +coreSatTopRhs b rhs + = coreSatExprFloat rhs `thenUs` \ (floats, rhs1) -> + if exprIsValue rhs then + ASSERT( allLazy floats ) + WARN( idArity b /= exprArity rhs1, ptext SLIT("Disaster!") <+> ppr b ) + returnUs ([bind | FloatLet bind <- fromOL floats], rhs1) + else + mkBinds floats rhs1 `thenUs` \ rhs2 -> + WARN( idArity b /= exprArity rhs2, ptext SLIT("Disaster!") <+> ppr b ) + returnUs ([], rhs2) + + +coreSatBind :: CoreBind -> UniqSM (OrdList FloatingBind) +-- Used for non-top-level bindings +-- We return a *list* of bindings because we may start with +-- x* = f (g y) +-- where x is demanded, in which case we want to finish with +-- a = g y +-- x* = f a +-- And then x will actually end up case-bound + coreSatBind (NonRec binder rhs) - = coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) -> - returnUs (NonRecF binder new_rhs (bdrDem binder) floats) + = coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) -> + mkNonRec binder (bdrDem binder) floats new_rhs + -- NB: if there are any lambdas at the top of the RHS, + -- the floats will be empty, so the arity won't be affected + coreSatBind (Rec pairs) - = mapUs do_rhs pairs `thenUs` \ new_rhss -> - returnUs (RecF (binders `zip` new_rhss)) + -- Don't bother to try to float bindings out of RHSs + -- (compare mkNonRec, which does try) + = mapUs do_rhs pairs `thenUs` \ new_pairs -> + returnUs (unitOL (FloatLet (Rec new_pairs))) where - binders = map fst pairs - do_rhs (bndr,rhs) = - coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) -> - mkBinds floats new_rhs `thenUs` \ new_rhs' -> - -- NB: new_rhs' might still be a Lam (and we want that) - returnUs new_rhs' + do_rhs (bndr,rhs) = coreSatAnExpr rhs `thenUs` \ new_rhs' -> + returnUs (bndr,new_rhs') + -- --------------------------------------------------------------------------- -- Making arguments atomic (function args & constructor args) -- --------------------------------------------------------------------------- -- This is where we arrange that a non-trivial argument is let-bound -coreSatArg :: CoreArg -> RhsDemand -> UniqSM ([FloatingBind], CoreArg) +coreSatArg :: CoreArg -> RhsDemand -> UniqSM (OrdList FloatingBind, CoreArg) coreSatArg arg dem = coreSatExprFloat arg `thenUs` \ (floats, arg') -> - if exprIsTrivial arg' + if needs_binding arg' then returnUs (floats, arg') else newVar (exprType arg') `thenUs` \ v -> - returnUs ([NonRecF v arg' dem floats], Var v) + mkNonRec v dem floats arg' `thenUs` \ floats' -> + returnUs (floats', Var v) + +needs_binding | opt_KeepStgTypes = exprIsAtom + | otherwise = exprIsTrivial -- --------------------------------------------------------------------------- -- Dealing with expressions @@ -151,7 +213,7 @@ coreSatAnExpr expr mkBinds floats expr -coreSatExprFloat :: CoreExpr -> UniqSM ([FloatingBind], CoreExpr) +coreSatExprFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr) -- If -- e ===> (bs, e') -- then @@ -162,26 +224,33 @@ coreSatExprFloat :: CoreExpr -> UniqSM ([FloatingBind], CoreExpr) coreSatExprFloat (Var v) = maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app -> - returnUs ([], app) + returnUs (nilOL, app) coreSatExprFloat (Lit lit) - = returnUs ([], Lit lit) + = returnUs (nilOL, Lit lit) coreSatExprFloat (Let bind body) - = coreSatBind bind `thenUs` \ new_bind -> + = coreSatBind bind `thenUs` \ new_binds -> coreSatExprFloat body `thenUs` \ (floats, new_body) -> - returnUs (new_bind:floats, new_body) + returnUs (new_binds `appOL` floats, new_body) + +coreSatExprFloat (Note n@(SCC _) expr) + = coreSatAnExpr expr `thenUs` \ expr -> + deLam expr `thenUs` \ expr -> + returnUs (nilOL, Note n expr) coreSatExprFloat (Note other_note expr) = coreSatExprFloat expr `thenUs` \ (floats, expr) -> returnUs (floats, Note other_note expr) coreSatExprFloat expr@(Type _) - = returnUs ([], expr) + = returnUs (nilOL, expr) -coreSatExprFloat (Lam v e) - = coreSatAnExpr e `thenUs` \ e' -> - returnUs ([], Lam v e') +coreSatExprFloat expr@(Lam _ _) + = coreSatAnExpr body `thenUs` \ body' -> + returnUs (nilOL, mkLams bndrs body') + where + (bndrs,body) = collectBinders expr coreSatExprFloat (Case scrut bndr alts) = coreSatExprFloat scrut `thenUs` \ (floats, scrut) -> @@ -189,8 +258,8 @@ coreSatExprFloat (Case scrut bndr alts) returnUs (floats, Case scrut bndr alts) where sat_alt (con, bs, rhs) - = coreSatAnExpr rhs `thenUs` \ rhs -> - deLam rhs `thenUs` \ rhs -> + = coreSatAnExpr rhs `thenUs` \ rhs -> + deLam rhs `thenUs` \ rhs -> returnUs (con, bs, rhs) coreSatExprFloat expr@(App _ _) @@ -208,19 +277,19 @@ coreSatExprFloat expr@(App _ _) -- Deconstruct and rebuild the application, floating any non-atomic -- arguments to the outside. We collect the type of the expression, - -- the head of the applicaiton, and the number of actual value arguments, + -- the head of the application, and the number of actual value arguments, -- all of which are used to possibly saturate this application if it -- has a constructor or primop at the head. collect_args :: CoreExpr - -> Int -- current app depth - -> UniqSM (CoreExpr, -- the rebuilt expression - (CoreExpr,Int), -- the head of the application, + -> Int -- current app depth + -> UniqSM (CoreExpr, -- the rebuilt expression + (CoreExpr,Int), -- the head of the application, -- and no. of args it was applied to - Type, -- type of the whole expr - [FloatingBind], -- any floats we pulled out - [Demand]) -- remaining argument demands + Type, -- type of the whole expr + OrdList FloatingBind, -- any floats we pulled out + [Demand]) -- remaining argument demands collect_args (App fun arg@(Type arg_ty)) depth = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) -> @@ -236,10 +305,10 @@ coreSatExprFloat expr@(App _ _) splitFunTy_maybe fun_ty in coreSatArg arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') -> - returnUs (App fun' arg', hd, res_ty, fs ++ floats, ss_rest) + returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest) collect_args (Var v) depth - = returnUs (Var v, (Var v, depth), idType v, [], stricts) + = returnUs (Var v, (Var v, depth), idType v, nilOL, stricts) where stricts = case idStrictness v of StrictnessInfo demands _ @@ -263,11 +332,12 @@ coreSatExprFloat expr@(App _ _) -- non-variable fun, better let-bind it collect_args fun depth - = newVar ty `thenUs` \ fn_id -> - coreSatExprFloat fun `thenUs` \ (fun_floats, fun) -> - returnUs (Var fn_id, (Var fn_id, depth), ty, - [NonRecF fn_id fun onceDem fun_floats], []) - where ty = exprType fun + = coreSatExprFloat fun `thenUs` \ (fun_floats, fun) -> + newVar ty `thenUs` \ fn_id -> + mkNonRec fn_id onceDem fun_floats fun `thenUs` \ floats -> + returnUs (Var fn_id, (Var fn_id, depth), ty, floats, []) + where + ty = exprType fun ignore_note InlineCall = True ignore_note InlineMe = True @@ -308,123 +378,114 @@ maybeSaturate fn expr n_args ty returnUs (etaExpand excess_arity us expr ty) -- --------------------------------------------------------------------------- --- Eliminate Lam as a non-rhs (STG doesn't have such a thing) +-- Precipitating the floating bindings -- --------------------------------------------------------------------------- -deLam (Note n e) - = deLam e `thenUs` \ e -> - returnUs (Note n e) - - -- types will all disappear, so that's ok -deLam (Lam x e) | isTyVar x - = deLam e `thenUs` \ e -> - returnUs (Lam x e) - -deLam expr@(Lam _ _) - -- Try for eta reduction - | Just e <- eta body - = returnUs e +-- mkNonRec is used for local bindings only, not top level +mkNonRec :: Id -> RhsDemand -- Lhs: id with demand + -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body + -> UniqSM (OrdList FloatingBind) +mkNonRec bndr dem floats rhs + | exprIsValue rhs && allLazy floats -- Notably constructor applications + = -- Why the test for allLazy? You might think that the only + -- floats we can get out of a value are eta expansions + -- e.g. C $wJust ==> let s = \x -> $wJust x in C s + -- Here we want to float the s binding. + -- + -- But if the programmer writes this: + -- f x = case x of { (a,b) -> \y -> a } + -- then the strictness analyser may say that f has strictness "S" + -- Later the eta expander will transform to + -- f x y = case x of { (a,b) -> a } + -- So now f has arity 2. Now CoreSat may see + -- v = f E + -- so the E argument will turn into a FloatCase. + -- Indeed we should end up with + -- v = case E of { r -> f r } + -- That is, we should not float, even though (f r) is a value + returnUs (floats `snocOL` FloatLet (NonRec bndr rhs)) + + | isUnLiftedType bndr_rep_ty || isStrictDem dem + = ASSERT( not (isUnboxedTupleType bndr_rep_ty) ) + returnUs (floats `snocOL` FloatCase bndr rhs) - -- Eta failed, so let-bind the lambda | otherwise - = newVar (exprType expr) `thenUs` \ fn -> - returnUs (Let (NonRec fn expr) (Var fn)) + = mkBinds floats rhs `thenUs` \ rhs' -> + returnUs (unitOL (FloatLet (NonRec bndr rhs'))) where - (bndrs, body) = collectBinders expr - - eta expr@(App _ _) - | n_remaining >= 0 && - and (zipWith ok bndrs last_args) && - not (any (`elemVarSet` fvs_remaining) bndrs) - = Just remaining_expr - where - (f, args) = collectArgs expr - remaining_expr = mkApps f remaining_args - fvs_remaining = exprFreeVars remaining_expr - (remaining_args, last_args) = splitAt n_remaining args - n_remaining = length args - length bndrs - - ok bndr (Var arg) = bndr == arg - ok bndr other = False - - eta (Let bind@(NonRec b r) body) - | not (any (`elemVarSet` fvs) bndrs) - = case eta body of - Just e -> Just (Let bind e) - Nothing -> Nothing - where fvs = exprFreeVars r + bndr_rep_ty = repType (idType bndr) - eta _ = Nothing - -deLam expr = returnUs expr +mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr +mkBinds binds body + | isNilOL binds = returnUs body + | otherwise = deLam body `thenUs` \ body' -> + returnUs (foldOL mk_bind body' binds) + where + mk_bind (FloatCase bndr rhs) body = Case rhs bndr [(DEFAULT, [], body)] + mk_bind (FloatLet bind) body = Let bind body -- --------------------------------------------------------------------------- --- Precipitating the floating bindings +-- Eliminate Lam as a non-rhs (STG doesn't have such a thing) +-- We arrange that they only show up as the RHS of a let(rec) -- --------------------------------------------------------------------------- -mkBinds :: [FloatingBind] -> CoreExpr -> UniqSM CoreExpr -mkBinds [] body = returnUs body -mkBinds (b:bs) body - = deLam body `thenUs` \ body' -> - go (b:bs) body' +deLam :: CoreExpr -> UniqSM CoreExpr +-- Remove top level lambdas by let-bindinig + +deLam (Note n expr) + = -- You can get things like + -- case e of { p -> coerce t (\s -> ...) } + deLam expr `thenUs` \ expr' -> + returnUs (Note n expr') + +deLam expr + | null bndrs = returnUs expr + | otherwise = case tryEta bndrs body of + Just no_lam_result -> returnUs no_lam_result + Nothing -> newVar (exprType expr) `thenUs` \ fn -> + returnUs (Let (NonRec fn expr) (Var fn)) where - go [] body = returnUs body - go (b:bs) body = go bs body `thenUs` \ body' -> - mkBind b body' - --- body can't be Lam -mkBind (RecF prs) body = returnUs (Let (Rec prs) body) - -mkBind (NonRecF bndr rhs dem floats) body -#ifdef DEBUG - -- We shouldn't get let or case of the form v=w - = if exprIsTrivial rhs - then pprTrace "mkBind" (ppr bndr <+> ppr rhs) - (mk_let bndr rhs dem floats body) - else mk_let bndr rhs dem floats body - -mk_let bndr rhs dem floats body -#endif - | isUnLiftedType bndr_rep_ty - = ASSERT( not (isUnboxedTupleType bndr_rep_ty) ) - mkBinds floats (Case rhs bndr [(DEFAULT, [], body)]) - - | is_whnf - = if is_strict then - -- Strict let with WHNF rhs - mkBinds floats $ - Let (NonRec bndr rhs) body - else - -- Lazy let with WHNF rhs; float until we find a strict binding - let - (floats_out, floats_in) = splitFloats floats - in - mkBinds floats_in rhs `thenUs` \ new_rhs -> - mkBinds floats_out $ - Let (NonRec bndr new_rhs) body - - | otherwise -- Not WHNF - = if is_strict then - -- Strict let with non-WHNF rhs - mkBinds floats (Case rhs bndr [(DEFAULT, [], body)]) - else - -- Lazy let with non-WHNF rhs, so keep the floats in the RHS - mkBinds floats rhs `thenUs` \ new_rhs -> - returnUs (Let (NonRec bndr new_rhs) body) - + (bndrs,body) = collectBinders expr + +-- Why try eta reduction? Hasn't the simplifier already done eta? +-- But the simplifier only eta reduces if that leaves something +-- trivial (like f, or f Int). But for deLam it would be enough to +-- get to a partial application, like (map f). + +tryEta bndrs expr@(App _ _) + | ok_to_eta_reduce f && + n_remaining >= 0 && + and (zipWith ok bndrs last_args) && + not (any (`elemVarSet` fvs_remaining) bndrs) + = Just remaining_expr where - bndr_rep_ty = repType (idType bndr) - is_strict = isStrictDem dem - is_whnf = exprIsValue rhs - -splitFloats fs@(NonRecF _ _ dem _ : _) - | isStrictDem dem = ([], fs) - -splitFloats (f : fs) = case splitFloats fs of - (fs_out, fs_in) -> (f : fs_out, fs_in) + (f, args) = collectArgs expr + remaining_expr = mkApps f remaining_args + fvs_remaining = exprFreeVars remaining_expr + (remaining_args, last_args) = splitAt n_remaining args + n_remaining = length args - length bndrs + + ok bndr (Var arg) = bndr == arg + ok bndr other = False + + -- we can't eta reduce something which must be saturated. + ok_to_eta_reduce (Var f) + = case idFlavour f of + PrimOpId op -> False + DataConId dc -> False + other -> True + ok_to_eta_reduce _ = False --safe. ToDo: generalise + +tryEta bndrs (Let bind@(NonRec b r) body) + | not (any (`elemVarSet` fvs) bndrs) + = case tryEta bndrs body of + Just e -> Just (Let bind e) + Nothing -> Nothing + where + fvs = exprFreeVars r -splitFloats [] = ([], []) +tryEta bndrs _ = Nothing -- ----------------------------------------------------------------------------- -- Demands @@ -461,3 +522,5 @@ safeDem, onceDem :: RhsDemand safeDem = RhsDemand False False -- always safe to use this onceDem = RhsDemand False True -- used at most once \end{code} + +