diff options
Diffstat (limited to 'compiler/stranal')
| -rw-r--r-- | compiler/stranal/DmdAnal.lhs | 1185 | ||||
| -rw-r--r-- | compiler/stranal/SaAbsInt.lhs | 925 | ||||
| -rw-r--r-- | compiler/stranal/SaLib.lhs | 130 | ||||
| -rw-r--r-- | compiler/stranal/StrictAnal.lhs | 494 | ||||
| -rw-r--r-- | compiler/stranal/WorkWrap.lhs | 403 | ||||
| -rw-r--r-- | compiler/stranal/WwLib.lhs | 514 |
6 files changed, 3651 insertions, 0 deletions
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs new file mode 100644 index 0000000000..c5cfb7b4bd --- /dev/null +++ b/compiler/stranal/DmdAnal.lhs @@ -0,0 +1,1185 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% + + ----------------- + A demand analysis + ----------------- + +\begin{code} +module DmdAnal ( dmdAnalPgm, dmdAnalTopRhs, + both {- needed by WwLib -} + ) where + +#include "HsVersions.h" + +import DynFlags ( DynFlags, DynFlag(..) ) +import StaticFlags ( opt_MaxWorkerArgs ) +import NewDemand -- All of it +import CoreSyn +import PprCore +import CoreUtils ( exprIsHNF, exprIsTrivial, exprArity ) +import DataCon ( dataConTyCon ) +import TyCon ( isProductTyCon, isRecursiveTyCon ) +import Id ( Id, idType, idInlinePragma, + isDataConWorkId, isGlobalId, idArity, +#ifdef OLD_STRICTNESS + idDemandInfo, idStrictness, idCprInfo, idName, +#endif + idNewStrictness, idNewStrictness_maybe, + setIdNewStrictness, idNewDemandInfo, + idNewDemandInfo_maybe, + setIdNewDemandInfo + ) +#ifdef OLD_STRICTNESS +import IdInfo ( newStrictnessFromOld, newDemand ) +#endif +import Var ( Var ) +import VarEnv +import TysWiredIn ( unboxedPairDataCon ) +import TysPrim ( realWorldStatePrimTy ) +import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly, + keysUFM, minusUFM, ufmToList, filterUFM ) +import Type ( isUnLiftedType, coreEqType ) +import CoreLint ( showPass, endPass ) +import Util ( mapAndUnzip, mapAccumL, mapAccumR, lengthIs ) +import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive, + RecFlag(..), isRec ) +import Maybes ( orElse, expectJust ) +import Outputable +\end{code} + +To think about + +* set a noinline pragma on bottoming Ids + +* Consider f x = x+1 `fatbar` error (show x) + We'd like to unbox x, even if that means reboxing it in the error case. + + +%************************************************************************ +%* * +\subsection{Top level stuff} +%* * +%************************************************************************ + +\begin{code} +dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind] +dmdAnalPgm dflags binds + = do { + showPass dflags "Demand analysis" ; + let { binds_plus_dmds = do_prog binds } ; + + endPass dflags "Demand analysis" + Opt_D_dump_stranal binds_plus_dmds ; +#ifdef OLD_STRICTNESS + -- Only if OLD_STRICTNESS is on, because only then is the old + -- strictness analyser run + let { dmd_changes = get_changes binds_plus_dmds } ; + printDump (text "Changes in demands" $$ dmd_changes) ; +#endif + return binds_plus_dmds + } + where + do_prog :: [CoreBind] -> [CoreBind] + do_prog binds = snd $ mapAccumL dmdAnalTopBind emptySigEnv binds + +dmdAnalTopBind :: SigEnv + -> CoreBind + -> (SigEnv, CoreBind) +dmdAnalTopBind sigs (NonRec id rhs) + = let + ( _, _, (_, rhs1)) = dmdAnalRhs TopLevel NonRecursive sigs (id, rhs) + (sigs2, _, (id2, rhs2)) = dmdAnalRhs TopLevel NonRecursive sigs (id, rhs1) + -- Do two passes to improve CPR information + -- See comments with ignore_cpr_info in mk_sig_ty + -- and with extendSigsWithLam + in + (sigs2, NonRec id2 rhs2) + +dmdAnalTopBind sigs (Rec pairs) + = let + (sigs', _, pairs') = dmdFix TopLevel sigs pairs + -- We get two iterations automatically + -- c.f. the NonRec case above + in + (sigs', Rec pairs') +\end{code} + +\begin{code} +dmdAnalTopRhs :: CoreExpr -> (StrictSig, CoreExpr) +-- Analyse the RHS and return +-- a) appropriate strictness info +-- b) the unfolding (decorated with stricntess info) +dmdAnalTopRhs rhs + = (sig, rhs2) + where + call_dmd = vanillaCall (exprArity rhs) + (_, rhs1) = dmdAnal emptySigEnv call_dmd rhs + (rhs_ty, rhs2) = dmdAnal emptySigEnv call_dmd rhs1 + sig = mkTopSigTy rhs rhs_ty + -- Do two passes; see notes with extendSigsWithLam + -- Otherwise we get bogus CPR info for constructors like + -- newtype T a = MkT a + -- The constructor looks like (\x::T a -> x), modulo the coerce + -- extendSigsWithLam will optimistically give x a CPR tag the + -- first time, which is wrong in the end. +\end{code} + +%************************************************************************ +%* * +\subsection{The analyser itself} +%* * +%************************************************************************ + +\begin{code} +dmdAnal :: SigEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr) + +dmdAnal sigs Abs e = (topDmdType, e) + +dmdAnal sigs dmd e + | not (isStrictDmd dmd) + = let + (res_ty, e') = dmdAnal sigs evalDmd e + in + (deferType res_ty, e') + -- It's important not to analyse e with a lazy demand because + -- a) When we encounter case s of (a,b) -> + -- we demand s with U(d1d2)... but if the overall demand is lazy + -- that is wrong, and we'd need to reduce the demand on s, + -- which is inconvenient + -- b) More important, consider + -- f (let x = R in x+x), where f is lazy + -- We still want to mark x as demanded, because it will be when we + -- enter the let. If we analyse f's arg with a Lazy demand, we'll + -- just mark x as Lazy + -- c) The application rule wouldn't be right either + -- Evaluating (f x) in a L demand does *not* cause + -- evaluation of f in a C(L) demand! + + +dmdAnal sigs dmd (Lit lit) + = (topDmdType, Lit lit) + +dmdAnal sigs dmd (Var var) + = (dmdTransform sigs var dmd, Var var) + +dmdAnal sigs dmd (Note n e) + = (dmd_ty, Note n e') + where + (dmd_ty, e') = dmdAnal sigs dmd' e + dmd' = case n of + Coerce _ _ -> evalDmd -- This coerce usually arises from a recursive + other -> dmd -- newtype, and we don't want to look inside them + -- for exactly the same reason that we don't look + -- inside recursive products -- we might not reach + -- a fixpoint. So revert to a vanilla Eval demand + +dmdAnal sigs dmd (App fun (Type ty)) + = (fun_ty, App fun' (Type ty)) + where + (fun_ty, fun') = dmdAnal sigs dmd fun + +-- Lots of the other code is there to make this +-- beautiful, compositional, application rule :-) +dmdAnal sigs dmd e@(App fun arg) -- Non-type arguments + = let -- [Type arg handled above] + (fun_ty, fun') = dmdAnal sigs (Call dmd) fun + (arg_ty, arg') = dmdAnal sigs arg_dmd arg + (arg_dmd, res_ty) = splitDmdTy fun_ty + in + (res_ty `bothType` arg_ty, App fun' arg') + +dmdAnal sigs dmd (Lam var body) + | isTyVar var + = let + (body_ty, body') = dmdAnal sigs dmd body + in + (body_ty, Lam var body') + + | Call body_dmd <- dmd -- A call demand: good! + = let + sigs' = extendSigsWithLam sigs var + (body_ty, body') = dmdAnal sigs' body_dmd body + (lam_ty, var') = annotateLamIdBndr body_ty var + in + (lam_ty, Lam var' body') + + | otherwise -- Not enough demand on the lambda; but do the body + = let -- anyway to annotate it and gather free var info + (body_ty, body') = dmdAnal sigs evalDmd body + (lam_ty, var') = annotateLamIdBndr body_ty var + in + (deferType lam_ty, Lam var' body') + +dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)]) + | let tycon = dataConTyCon dc, + isProductTyCon tycon, + not (isRecursiveTyCon tycon) + = let + sigs_alt = extendSigEnv NotTopLevel sigs case_bndr case_bndr_sig + (alt_ty, alt') = dmdAnalAlt sigs_alt dmd alt + (alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr + (_, bndrs', _) = alt' + case_bndr_sig = cprSig + -- Inside the alternative, the case binder has the CPR property. + -- Meaning that a case on it will successfully cancel. + -- Example: + -- f True x = case x of y { I# x' -> if x' ==# 3 then y else I# 8 } + -- f False x = I# 3 + -- + -- We want f to have the CPR property: + -- f b x = case fw b x of { r -> I# r } + -- fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } + -- fw False x = 3 + + -- Figure out whether the demand on the case binder is used, and use + -- that to set the scrut_dmd. This is utterly essential. + -- Consider f x = case x of y { (a,b) -> k y a } + -- If we just take scrut_demand = U(L,A), then we won't pass x to the + -- worker, so the worker will rebuild + -- x = (a, absent-error) + -- and that'll crash. + -- So at one stage I had: + -- dead_case_bndr = isAbsentDmd (idNewDemandInfo case_bndr') + -- keepity | dead_case_bndr = Drop + -- | otherwise = Keep + -- + -- But then consider + -- case x of y { (a,b) -> h y + a } + -- where h : U(LL) -> T + -- The above code would compute a Keep for x, since y is not Abs, which is silly + -- The insight is, of course, that a demand on y is a demand on the + -- scrutinee, so we need to `both` it with the scrut demand + + scrut_dmd = Eval (Prod [idNewDemandInfo b | b <- bndrs', isId b]) + `both` + idNewDemandInfo case_bndr' + + (scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut + in + (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' ty [alt']) + +dmdAnal sigs dmd (Case scrut case_bndr ty alts) + = let + (alt_tys, alts') = mapAndUnzip (dmdAnalAlt sigs dmd) alts + (scrut_ty, scrut') = dmdAnal sigs evalDmd scrut + (alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr + in +-- pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys) + (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' ty alts') + +dmdAnal sigs dmd (Let (NonRec id rhs) body) + = let + (sigs', lazy_fv, (id1, rhs')) = dmdAnalRhs NotTopLevel NonRecursive sigs (id, rhs) + (body_ty, body') = dmdAnal sigs' dmd body + (body_ty1, id2) = annotateBndr body_ty id1 + body_ty2 = addLazyFVs body_ty1 lazy_fv + in + -- If the actual demand is better than the vanilla call + -- demand, you might think that we might do better to re-analyse + -- the RHS with the stronger demand. + -- But (a) That seldom happens, because it means that *every* path in + -- the body of the let has to use that stronger demand + -- (b) It often happens temporarily in when fixpointing, because + -- the recursive function at first seems to place a massive demand. + -- But we don't want to go to extra work when the function will + -- probably iterate to something less demanding. + -- In practice, all the times the actual demand on id2 is more than + -- the vanilla call demand seem to be due to (b). So we don't + -- bother to re-analyse the RHS. + (body_ty2, Let (NonRec id2 rhs') body') + +dmdAnal sigs dmd (Let (Rec pairs) body) + = let + bndrs = map fst pairs + (sigs', lazy_fv, pairs') = dmdFix NotTopLevel sigs pairs + (body_ty, body') = dmdAnal sigs' dmd body + body_ty1 = addLazyFVs body_ty lazy_fv + in + sigs' `seq` body_ty `seq` + let + (body_ty2, _) = annotateBndrs body_ty1 bndrs + -- Don't bother to add demand info to recursive + -- binders as annotateBndr does; + -- being recursive, we can't treat them strictly. + -- But we do need to remove the binders from the result demand env + in + (body_ty2, Let (Rec pairs') body') + + +dmdAnalAlt sigs dmd (con,bndrs,rhs) + = let + (rhs_ty, rhs') = dmdAnal sigs dmd rhs + (alt_ty, bndrs') = annotateBndrs rhs_ty bndrs + final_alt_ty | io_hack_reqd = alt_ty `lubType` topDmdType + | otherwise = alt_ty + + -- There's a hack here for I/O operations. Consider + -- case foo x s of { (# s, r #) -> y } + -- Is this strict in 'y'. Normally yes, but what if 'foo' is an I/O + -- operation that simply terminates the program (not in an erroneous way)? + -- In that case we should not evaluate y before the call to 'foo'. + -- Hackish solution: spot the IO-like situation and add a virtual branch, + -- as if we had + -- case foo x s of + -- (# s, r #) -> y + -- other -> return () + -- So the 'y' isn't necessarily going to be evaluated + -- + -- A more complete example where this shows up is: + -- do { let len = <expensive> ; + -- ; when (...) (exitWith ExitSuccess) + -- ; print len } + + io_hack_reqd = con == DataAlt unboxedPairDataCon && + idType (head bndrs) `coreEqType` realWorldStatePrimTy + in + (final_alt_ty, (con, bndrs', rhs')) +\end{code} + +%************************************************************************ +%* * +\subsection{Bindings} +%* * +%************************************************************************ + +\begin{code} +dmdFix :: TopLevelFlag + -> SigEnv -- Does not include bindings for this binding + -> [(Id,CoreExpr)] + -> (SigEnv, DmdEnv, + [(Id,CoreExpr)]) -- Binders annotated with stricness info + +dmdFix top_lvl sigs orig_pairs + = loop 1 initial_sigs orig_pairs + where + bndrs = map fst orig_pairs + initial_sigs = extendSigEnvList sigs [(id, (initialSig id, top_lvl)) | id <- bndrs] + + loop :: Int + -> SigEnv -- Already contains the current sigs + -> [(Id,CoreExpr)] + -> (SigEnv, DmdEnv, [(Id,CoreExpr)]) + loop n sigs pairs + | found_fixpoint + = (sigs', lazy_fv, pairs') + -- Note: use pairs', not pairs. pairs' is the result of + -- processing the RHSs with sigs (= sigs'), whereas pairs + -- is the result of processing the RHSs with the *previous* + -- iteration of sigs. + + | n >= 10 = pprTrace "dmdFix loop" (ppr n <+> (vcat + [ text "Sigs:" <+> ppr [(id,lookup sigs id, lookup sigs' id) | (id,_) <- pairs], + text "env:" <+> ppr (ufmToList sigs), + text "binds:" <+> pprCoreBinding (Rec pairs)])) + (emptySigEnv, lazy_fv, orig_pairs) -- Safe output + -- The lazy_fv part is really important! orig_pairs has no strictness + -- info, including nothing about free vars. But if we have + -- letrec f = ....y..... in ...f... + -- where 'y' is free in f, we must record that y is mentioned, + -- otherwise y will get recorded as absent altogether + + | otherwise = loop (n+1) sigs' pairs' + where + found_fixpoint = all (same_sig sigs sigs') bndrs + -- Use the new signature to do the next pair + -- The occurrence analyser has arranged them in a good order + -- so this can significantly reduce the number of iterations needed + ((sigs',lazy_fv), pairs') = mapAccumL (my_downRhs top_lvl) (sigs, emptyDmdEnv) pairs + + my_downRhs top_lvl (sigs,lazy_fv) (id,rhs) + = -- pprTrace "downRhs {" (ppr id <+> (ppr old_sig)) + -- (new_sig `seq` + -- pprTrace "downRhsEnd" (ppr id <+> ppr new_sig <+> char '}' ) + ((sigs', lazy_fv'), pair') + -- ) + where + (sigs', lazy_fv1, pair') = dmdAnalRhs top_lvl Recursive sigs (id,rhs) + lazy_fv' = plusUFM_C both lazy_fv lazy_fv1 + -- old_sig = lookup sigs id + -- new_sig = lookup sigs' id + + same_sig sigs sigs' var = lookup sigs var == lookup sigs' var + lookup sigs var = case lookupVarEnv sigs var of + Just (sig,_) -> sig + + -- Get an initial strictness signature from the Id + -- itself. That way we make use of earlier iterations + -- of the fixpoint algorithm. (Cunning plan.) + -- Note that the cunning plan extends to the DmdEnv too, + -- since it is part of the strictness signature +initialSig id = idNewStrictness_maybe id `orElse` botSig + +dmdAnalRhs :: TopLevelFlag -> RecFlag + -> SigEnv -> (Id, CoreExpr) + -> (SigEnv, DmdEnv, (Id, CoreExpr)) +-- Process the RHS of the binding, add the strictness signature +-- to the Id, and augment the environment with the signature as well. + +dmdAnalRhs top_lvl rec_flag sigs (id, rhs) + = (sigs', lazy_fv, (id', rhs')) + where + arity = idArity id -- The idArity should be up to date + -- The simplifier was run just beforehand + (rhs_dmd_ty, rhs') = dmdAnal sigs (vanillaCall arity) rhs + (lazy_fv, sig_ty) = WARN( arity /= dmdTypeDepth rhs_dmd_ty && not (exprIsTrivial rhs), ppr id ) + -- The RHS can be eta-reduced to just a variable, + -- in which case we should not complain. + mkSigTy top_lvl rec_flag id rhs rhs_dmd_ty + id' = id `setIdNewStrictness` sig_ty + sigs' = extendSigEnv top_lvl sigs id sig_ty +\end{code} + +%************************************************************************ +%* * +\subsection{Strictness signatures and types} +%* * +%************************************************************************ + +\begin{code} +mkTopSigTy :: CoreExpr -> DmdType -> StrictSig + -- Take a DmdType and turn it into a StrictSig + -- NB: not used for never-inline things; hence False +mkTopSigTy rhs dmd_ty = snd (mk_sig_ty False False rhs dmd_ty) + +mkSigTy :: TopLevelFlag -> RecFlag -> Id -> CoreExpr -> DmdType -> (DmdEnv, StrictSig) +mkSigTy top_lvl rec_flag id rhs dmd_ty + = mk_sig_ty never_inline thunk_cpr_ok rhs dmd_ty + where + never_inline = isNeverActive (idInlinePragma id) + maybe_id_dmd = idNewDemandInfo_maybe id + -- Is Nothing the first time round + + thunk_cpr_ok + | isTopLevel top_lvl = False -- Top level things don't get + -- their demandInfo set at all + | isRec rec_flag = False -- Ditto recursive things + | Just dmd <- maybe_id_dmd = isStrictDmd dmd + | otherwise = True -- Optimistic, first time round + -- See notes below +\end{code} + +The thunk_cpr_ok stuff [CPR-AND-STRICTNESS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the rhs is a thunk, we usually forget the CPR info, because +it is presumably shared (else it would have been inlined, and +so we'd lose sharing if w/w'd it into a function. + +However, if the strictness analyser has figured out (in a previous +iteration) that it's strict, then we DON'T need to forget the CPR info. +Instead we can retain the CPR info and do the thunk-splitting transform +(see WorkWrap.splitThunk). + +This made a big difference to PrelBase.modInt, which had something like + modInt = \ x -> let r = ... -> I# v in + ...body strict in r... +r's RHS isn't a value yet; but modInt returns r in various branches, so +if r doesn't have the CPR property then neither does modInt +Another case I found in practice (in Complex.magnitude), looks like this: + let k = if ... then I# a else I# b + in ... body strict in k .... +(For this example, it doesn't matter whether k is returned as part of +the overall result; but it does matter that k's RHS has the CPR property.) +Left to itself, the simplifier will make a join point thus: + let $j k = ...body strict in k... + if ... then $j (I# a) else $j (I# b) +With thunk-splitting, we get instead + let $j x = let k = I#x in ...body strict in k... + in if ... then $j a else $j b +This is much better; there's a good chance the I# won't get allocated. + +The difficulty with this is that we need the strictness type to +look at the body... but we now need the body to calculate the demand +on the variable, so we can decide whether its strictness type should +have a CPR in it or not. Simple solution: + a) use strictness info from the previous iteration + b) make sure we do at least 2 iterations, by doing a second + round for top-level non-recs. Top level recs will get at + least 2 iterations except for totally-bottom functions + which aren't very interesting anyway. + +NB: strictly_demanded is never true of a top-level Id, or of a recursive Id. + +The Nothing case in thunk_cpr_ok [CPR-AND-STRICTNESS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Demand info now has a 'Nothing' state, just like strictness info. +The analysis works from 'dangerous' towards a 'safe' state; so we +start with botSig for 'Nothing' strictness infos, and we start with +"yes, it's demanded" for 'Nothing' in the demand info. The +fixpoint iteration will sort it all out. + +We can't start with 'not-demanded' because then consider + f x = let + t = ... I# x + in + if ... then t else I# y else f x' + +In the first iteration we'd have no demand info for x, so assume +not-demanded; then we'd get TopRes for f's CPR info. Next iteration +we'd see that t was demanded, and so give it the CPR property, but by +now f has TopRes, so it will stay TopRes. Instead, with the Nothing +setting the first time round, we say 'yes t is demanded' the first +time. + +However, this does mean that for non-recursive bindings we must +iterate twice to be sure of not getting over-optimistic CPR info, +in the case where t turns out to be not-demanded. This is handled +by dmdAnalTopBind. + + +\begin{code} +mk_sig_ty never_inline thunk_cpr_ok rhs (DmdType fv dmds res) + | never_inline && not (isBotRes res) + -- HACK ALERT + -- Don't strictness-analyse NOINLINE things. Why not? Because + -- the NOINLINE says "don't expose any of the inner workings at the call + -- site" and the strictness is certainly an inner working. + -- + -- More concretely, the demand analyser discovers the following strictness + -- for unsafePerformIO: C(U(AV)) + -- But then consider + -- unsafePerformIO (\s -> let r = f x in + -- case writeIORef v r s of (# s1, _ #) -> + -- (# s1, r #) + -- The strictness analyser will find that the binding for r is strict, + -- (becuase of uPIO's strictness sig), and so it'll evaluate it before + -- doing the writeIORef. This actually makes tests/lib/should_run/memo002 + -- get a deadlock! + -- + -- Solution: don't expose the strictness of unsafePerformIO. + -- + -- But we do want to expose the strictness of error functions, + -- which are also often marked NOINLINE + -- {-# NOINLINE foo #-} + -- foo x = error ("wubble buggle" ++ x) + -- So (hack, hack) we only drop the strictness for non-bottom things + -- This is all very unsatisfactory. + = (deferEnv fv, topSig) + + | otherwise + = (lazy_fv, mkStrictSig dmd_ty) + where + dmd_ty = DmdType strict_fv final_dmds res' + + lazy_fv = filterUFM (not . isStrictDmd) fv + strict_fv = filterUFM isStrictDmd fv + -- We put the strict FVs in the DmdType of the Id, so + -- that at its call sites we unleash demands on its strict fvs. + -- An example is 'roll' in imaginary/wheel-sieve2 + -- Something like this: + -- roll x = letrec + -- go y = if ... then roll (x-1) else x+1 + -- in + -- go ms + -- We want to see that roll is strict in x, which is because + -- go is called. So we put the DmdEnv for x in go's DmdType. + -- + -- Another example: + -- f :: Int -> Int -> Int + -- f x y = let t = x+1 + -- h z = if z==0 then t else + -- if z==1 then x+1 else + -- x + h (z-1) + -- in + -- h y + -- Calling h does indeed evaluate x, but we can only see + -- that if we unleash a demand on x at the call site for t. + -- + -- Incidentally, here's a place where lambda-lifting h would + -- lose the cigar --- we couldn't see the joint strictness in t/x + -- + -- ON THE OTHER HAND + -- We don't want to put *all* the fv's from the RHS into the + -- DmdType, because that makes fixpointing very slow --- the + -- DmdType gets full of lazy demands that are slow to converge. + + final_dmds = setUnpackStrategy dmds + -- Set the unpacking strategy + + res' = case res of + RetCPR | ignore_cpr_info -> TopRes + other -> res + ignore_cpr_info = not (exprIsHNF rhs || thunk_cpr_ok) +\end{code} + +The unpack strategy determines whether we'll *really* unpack the argument, +or whether we'll just remember its strictness. If unpacking would give +rise to a *lot* of worker args, we may decide not to unpack after all. + +\begin{code} +setUnpackStrategy :: [Demand] -> [Demand] +setUnpackStrategy ds + = snd (go (opt_MaxWorkerArgs - nonAbsentArgs ds) ds) + where + go :: Int -- Max number of args available for sub-components of [Demand] + -> [Demand] + -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked + + go n (Eval (Prod cs) : ds) + | n' >= 0 = Eval (Prod cs') `cons` go n'' ds + | otherwise = Box (Eval (Prod cs)) `cons` go n ds + where + (n'',cs') = go n' cs + n' = n + 1 - non_abs_args + -- Add one to the budget 'cos we drop the top-level arg + non_abs_args = nonAbsentArgs cs + -- Delete # of non-absent args to which we'll now be committed + + go n (d:ds) = d `cons` go n ds + go n [] = (n,[]) + + cons d (n,ds) = (n, d:ds) + +nonAbsentArgs :: [Demand] -> Int +nonAbsentArgs [] = 0 +nonAbsentArgs (Abs : ds) = nonAbsentArgs ds +nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds +\end{code} + + +%************************************************************************ +%* * +\subsection{Strictness signatures and types} +%* * +%************************************************************************ + +\begin{code} +splitDmdTy :: DmdType -> (Demand, DmdType) +-- Split off one function argument +-- We already have a suitable demand on all +-- free vars, so no need to add more! +splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) +splitDmdTy ty@(DmdType fv [] res_ty) = (resTypeArgDmd res_ty, ty) +\end{code} + +\begin{code} +unitVarDmd var dmd = DmdType (unitVarEnv var dmd) [] TopRes + +addVarDmd top_lvl dmd_ty@(DmdType fv ds res) var dmd + | isTopLevel top_lvl = dmd_ty -- Don't record top level things + | otherwise = DmdType (extendVarEnv fv var dmd) ds res + +addLazyFVs (DmdType fv ds res) lazy_fvs + = DmdType both_fv1 ds res + where + both_fv = (plusUFM_C both fv lazy_fvs) + both_fv1 = modifyEnv (isBotRes res) (`both` Bot) lazy_fvs fv both_fv + -- This modifyEnv is vital. Consider + -- let f = \x -> (x,y) + -- in error (f 3) + -- Here, y is treated as a lazy-fv of f, but we must `both` that L + -- demand with the bottom coming up from 'error' + -- + -- I got a loop in the fixpointer without this, due to an interaction + -- with the lazy_fv filtering in mkSigTy. Roughly, it was + -- letrec f n x + -- = letrec g y = x `fatbar` + -- letrec h z = z + ...g... + -- in h (f (n-1) x) + -- in ... + -- In the initial iteration for f, f=Bot + -- Suppose h is found to be strict in z, but the occurrence of g in its RHS + -- is lazy. Now consider the fixpoint iteration for g, esp the demands it + -- places on its free variables. Suppose it places none. Then the + -- x `fatbar` ...call to h... + -- will give a x->V demand for x. That turns into a L demand for x, + -- which floats out of the defn for h. Without the modifyEnv, that + -- L demand doesn't get both'd with the Bot coming up from the inner + -- call to f. So we just get an L demand for x for g. + -- + -- A better way to say this is that the lazy-fv filtering should give the + -- same answer as putting the lazy fv demands in the function's type. + +annotateBndr :: DmdType -> Var -> (DmdType, Var) +-- The returned env has the var deleted +-- The returned var is annotated with demand info +-- No effect on the argument demands +annotateBndr dmd_ty@(DmdType fv ds res) var + | isTyVar var = (dmd_ty, var) + | otherwise = (DmdType fv' ds res, setIdNewDemandInfo var dmd) + where + (fv', dmd) = removeFV fv var res + +annotateBndrs = mapAccumR annotateBndr + +annotateLamIdBndr dmd_ty@(DmdType fv ds res) id +-- For lambdas we add the demand to the argument demands +-- Only called for Ids + = ASSERT( isId id ) + (DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd) + where + (fv', dmd) = removeFV fv id res + hacked_dmd = argDemand dmd + -- This call to argDemand is vital, because otherwise we label + -- a lambda binder with demand 'B'. But in terms of calling + -- conventions that's Abs, because we don't pass it. But + -- when we do a w/w split we get + -- fw x = (\x y:B -> ...) x (error "oops") + -- And then the simplifier things the 'B' is a strict demand + -- and evaluates the (error "oops"). Sigh + +removeFV fv id res = (fv', zapUnlifted id dmd) + where + fv' = fv `delVarEnv` id + dmd = lookupVarEnv fv id `orElse` deflt + deflt | isBotRes res = Bot + | otherwise = Abs + +-- For unlifted-type variables, we are only +-- interested in Bot/Abs/Box Abs +zapUnlifted is Bot = Bot +zapUnlifted id Abs = Abs +zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd + | otherwise = dmd +\end{code} + +%************************************************************************ +%* * +\subsection{Strictness signatures} +%* * +%************************************************************************ + +\begin{code} +type SigEnv = VarEnv (StrictSig, TopLevelFlag) + -- We use the SigEnv to tell us whether to + -- record info about a variable in the DmdEnv + -- We do so if it's a LocalId, but not top-level + -- + -- The DmdEnv gives the demand on the free vars of the function + -- when it is given enough args to satisfy the strictness signature + +emptySigEnv = emptyVarEnv + +extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv +extendSigEnv top_lvl env var sig = extendVarEnv env var (sig, top_lvl) + +extendSigEnvList = extendVarEnvList + +extendSigsWithLam :: SigEnv -> Id -> SigEnv +-- Extend the SigEnv when we meet a lambda binder +-- If the binder is marked demanded with a product demand, then give it a CPR +-- signature, because in the likely event that this is a lambda on a fn defn +-- [we only use this when the lambda is being consumed with a call demand], +-- it'll be w/w'd and so it will be CPR-ish. E.g. +-- f = \x::(Int,Int). if ...strict in x... then +-- x +-- else +-- (a,b) +-- We want f to have the CPR property because x does, by the time f has been w/w'd +-- +-- Also note that we only want to do this for something that +-- definitely has product type, else we may get over-optimistic +-- CPR results (e.g. from \x -> x!). + +extendSigsWithLam sigs id + = case idNewDemandInfo_maybe id of + Nothing -> extendVarEnv sigs id (cprSig, NotTopLevel) + -- Optimistic in the Nothing case; + -- See notes [CPR-AND-STRICTNESS] + Just (Eval (Prod ds)) -> extendVarEnv sigs id (cprSig, NotTopLevel) + other -> sigs + + +dmdTransform :: SigEnv -- The strictness environment + -> Id -- The function + -> Demand -- The demand on the function + -> DmdType -- The demand type of the function in this context + -- Returned DmdEnv includes the demand on + -- this function plus demand on its free variables + +dmdTransform sigs var dmd + +------ DATA CONSTRUCTOR + | isDataConWorkId var -- Data constructor + = let + StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig + DmdType _ _ con_res = dmd_ty + arity = idArity var + in + if arity == call_depth then -- Saturated, so unleash the demand + let + -- Important! If we Keep the constructor application, then + -- we need the demands the constructor places (always lazy) + -- If not, we don't need to. For example: + -- f p@(x,y) = (p,y) -- S(AL) + -- g a b = f (a,b) + -- It's vital that we don't calculate Absent for a! + dmd_ds = case res_dmd of + Box (Eval ds) -> mapDmds box ds + Eval ds -> ds + other -> Poly Top + + -- ds can be empty, when we are just seq'ing the thing + -- If so we must make up a suitable bunch of demands + arg_ds = case dmd_ds of + Poly d -> replicate arity d + Prod ds -> ASSERT( ds `lengthIs` arity ) ds + + in + mkDmdType emptyDmdEnv arg_ds con_res + -- Must remember whether it's a product, hence con_res, not TopRes + else + topDmdType + +------ IMPORTED FUNCTION + | isGlobalId var, -- Imported function + let StrictSig dmd_ty = idNewStrictness var + = if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand + dmd_ty + else + topDmdType + +------ LOCAL LET/REC BOUND THING + | Just (StrictSig dmd_ty, top_lvl) <- lookupVarEnv sigs var + = let + fn_ty | dmdTypeDepth dmd_ty <= call_depth = dmd_ty + | otherwise = deferType dmd_ty + -- NB: it's important to use deferType, and not just return topDmdType + -- Consider let { f x y = p + x } in f 1 + -- The application isn't saturated, but we must nevertheless propagate + -- a lazy demand for p! + in + addVarDmd top_lvl fn_ty var dmd + +------ LOCAL NON-LET/REC BOUND THING + | otherwise -- Default case + = unitVarDmd var dmd + + where + (call_depth, res_dmd) = splitCallDmd dmd +\end{code} + + +%************************************************************************ +%* * +\subsection{Demands} +%* * +%************************************************************************ + +\begin{code} +splitCallDmd :: Demand -> (Int, Demand) +splitCallDmd (Call d) = case splitCallDmd d of + (n, r) -> (n+1, r) +splitCallDmd d = (0, d) + +vanillaCall :: Arity -> Demand +vanillaCall 0 = evalDmd +vanillaCall n = Call (vanillaCall (n-1)) + +deferType :: DmdType -> DmdType +deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] TopRes + -- Notice that we throw away info about both arguments and results + -- For example, f = let ... in \x -> x + -- We don't want to get a stricness type V->T for f. + -- Peter?? + +deferEnv :: DmdEnv -> DmdEnv +deferEnv fv = mapVarEnv defer fv + + +---------------- +argDemand :: Demand -> Demand +-- The 'Defer' demands are just Lazy at function boundaries +-- Ugly! Ask John how to improve it. +argDemand Top = lazyDmd +argDemand (Defer d) = lazyDmd +argDemand (Eval ds) = Eval (mapDmds argDemand ds) +argDemand (Box Bot) = evalDmd +argDemand (Box d) = box (argDemand d) +argDemand Bot = Abs -- Don't pass args that are consumed (only) by bottom +argDemand d = d +\end{code} + +\begin{code} +------------------------- +-- Consider (if x then y else []) with demand V +-- Then the first branch gives {y->V} and the second +-- *implicitly* has {y->A}. So we must put {y->(V `lub` A)} +-- in the result env. +lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2) + = DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubRes` r2) + where + lub_fv = plusUFM_C lub fv1 fv2 + lub_fv1 = modifyEnv (not (isBotRes r1)) absLub fv2 fv1 lub_fv + lub_fv2 = modifyEnv (not (isBotRes r2)) absLub fv1 fv2 lub_fv1 + -- lub is the identity for Bot + + -- Extend the shorter argument list to match the longer + lub_ds (d1:ds1) (d2:ds2) = lub d1 d2 : lub_ds ds1 ds2 + lub_ds [] [] = [] + lub_ds ds1 [] = map (`lub` resTypeArgDmd r2) ds1 + lub_ds [] ds2 = map (resTypeArgDmd r1 `lub`) ds2 + +----------------------------------- +-- (t1 `bothType` t2) takes the argument/result info from t1, +-- using t2 just for its free-var info +-- NB: Don't forget about r2! It might be BotRes, which is +-- a bottom demand on all the in-scope variables. +-- Peter: can this be done more neatly? +bothType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2) + = DmdType both_fv2 ds1 (r1 `bothRes` r2) + where + both_fv = plusUFM_C both fv1 fv2 + both_fv1 = modifyEnv (isBotRes r1) (`both` Bot) fv2 fv1 both_fv + both_fv2 = modifyEnv (isBotRes r2) (`both` Bot) fv1 fv2 both_fv1 + -- both is the identity for Abs +\end{code} + + +\begin{code} +lubRes BotRes r = r +lubRes r BotRes = r +lubRes RetCPR RetCPR = RetCPR +lubRes r1 r2 = TopRes + +-- If either diverges, the whole thing does +-- Otherwise take CPR info from the first +bothRes r1 BotRes = BotRes +bothRes r1 r2 = r1 +\end{code} + +\begin{code} +modifyEnv :: Bool -- No-op if False + -> (Demand -> Demand) -- The zapper + -> DmdEnv -> DmdEnv -- Env1 and Env2 + -> DmdEnv -> DmdEnv -- Transform this env + -- Zap anything in Env1 but not in Env2 + -- Assume: dom(env) includes dom(Env1) and dom(Env2) + +modifyEnv need_to_modify zapper env1 env2 env + | need_to_modify = foldr zap env (keysUFM (env1 `minusUFM` env2)) + | otherwise = env + where + zap uniq env = addToUFM_Directly env uniq (zapper current_val) + where + current_val = expectJust "modifyEnv" (lookupUFM_Directly env uniq) +\end{code} + + +%************************************************************************ +%* * +\subsection{LUB and BOTH} +%* * +%************************************************************************ + +\begin{code} +lub :: Demand -> Demand -> Demand + +lub Bot d2 = d2 +lub Abs d2 = absLub d2 +lub Top d2 = Top +lub (Defer ds1) d2 = defer (Eval ds1 `lub` d2) + +lub (Call d1) (Call d2) = Call (d1 `lub` d2) +lub d1@(Call _) (Box d2) = d1 `lub` d2 -- Just strip the box +lub d1@(Call _) d2@(Eval _) = d2 -- Presumably seq or vanilla eval +lub d1@(Call _) d2 = d2 `lub` d1 -- Bot, Abs, Top + +-- For the Eval case, we use these approximation rules +-- Box Bot <= Eval (Box Bot ...) +-- Box Top <= Defer (Box Bot ...) +-- Box (Eval ds) <= Eval (map Box ds) +lub (Eval ds1) (Eval ds2) = Eval (ds1 `lubs` ds2) +lub (Eval ds1) (Box Bot) = Eval (mapDmds (`lub` Box Bot) ds1) +lub (Eval ds1) (Box (Eval ds2)) = Eval (ds1 `lubs` mapDmds box ds2) +lub (Eval ds1) (Box Abs) = deferEval (mapDmds (`lub` Box Bot) ds1) +lub d1@(Eval _) d2 = d2 `lub` d1 -- Bot,Abs,Top,Call,Defer + +lub (Box d1) (Box d2) = box (d1 `lub` d2) +lub d1@(Box _) d2 = d2 `lub` d1 + +lubs = zipWithDmds lub + +--------------------- +-- box is the smart constructor for Box +-- It computes <B,bot> & d +-- INVARIANT: (Box d) => d = Bot, Abs, Eval +-- Seems to be no point in allowing (Box (Call d)) +box (Call d) = Call d -- The odd man out. Why? +box (Box d) = Box d +box (Defer _) = lazyDmd +box Top = lazyDmd -- Box Abs and Box Top +box Abs = lazyDmd -- are the same <B,L> +box d = Box d -- Bot, Eval + +--------------- +defer :: Demand -> Demand + +-- defer is the smart constructor for Defer +-- The idea is that (Defer ds) = <U(ds), L> +-- +-- It specifies what happens at a lazy function argument +-- or a lambda; the L* operator +-- Set the strictness part to L, but leave +-- the boxity side unaffected +-- It also ensures that Defer (Eval [LLLL]) = L + +defer Bot = Abs +defer Abs = Abs +defer Top = Top +defer (Call _) = lazyDmd -- Approximation here? +defer (Box _) = lazyDmd +defer (Defer ds) = Defer ds +defer (Eval ds) = deferEval ds + +-- deferEval ds = defer (Eval ds) +deferEval ds | allTop ds = Top + | otherwise = Defer ds + +--------------------- +absLub :: Demand -> Demand +-- Computes (Abs `lub` d) +-- For the Bot case consider +-- f x y = if ... then x else error x +-- Then for y we get Abs `lub` Bot, and we really +-- want Abs overall +absLub Bot = Abs +absLub Abs = Abs +absLub Top = Top +absLub (Call _) = Top +absLub (Box _) = Top +absLub (Eval ds) = Defer (absLubs ds) -- Or (Defer ds)? +absLub (Defer ds) = Defer (absLubs ds) -- Or (Defer ds)? + +absLubs = mapDmds absLub + +--------------- +both :: Demand -> Demand -> Demand + +both Abs d2 = d2 + +both Bot Bot = Bot +both Bot Abs = Bot +both Bot (Eval ds) = Eval (mapDmds (`both` Bot) ds) + -- Consider + -- f x = error x + -- From 'error' itself we get demand Bot on x + -- From the arg demand on x we get + -- x :-> evalDmd = Box (Eval (Poly Abs)) + -- So we get Bot `both` Box (Eval (Poly Abs)) + -- = Seq Keep (Poly Bot) + -- + -- Consider also + -- f x = if ... then error (fst x) else fst x + -- Then we get (Eval (Box Bot, Bot) `lub` Eval (SA)) + -- = Eval (SA) + -- which is what we want. +both Bot d = errDmd + +both Top Bot = errDmd +both Top Abs = Top +both Top Top = Top +both Top (Box d) = Box d +both Top (Call d) = Call d +both Top (Eval ds) = Eval (mapDmds (`both` Top) ds) +both Top (Defer ds) -- = defer (Top `both` Eval ds) + -- = defer (Eval (mapDmds (`both` Top) ds)) + = deferEval (mapDmds (`both` Top) ds) + + +both (Box d1) (Box d2) = box (d1 `both` d2) +both (Box d1) d2@(Call _) = box (d1 `both` d2) +both (Box d1) d2@(Eval _) = box (d1 `both` d2) +both (Box d1) (Defer d2) = Box d1 +both d1@(Box _) d2 = d2 `both` d1 + +both (Call d1) (Call d2) = Call (d1 `both` d2) +both (Call d1) (Eval ds2) = Call d1 -- Could do better for (Poly Bot)? +both (Call d1) (Defer ds2) = Call d1 -- Ditto +both d1@(Call _) d2 = d1 `both` d1 + +both (Eval ds1) (Eval ds2) = Eval (ds1 `boths` ds2) +both (Eval ds1) (Defer ds2) = Eval (ds1 `boths` mapDmds defer ds2) +both d1@(Eval ds1) d2 = d2 `both` d1 + +both (Defer ds1) (Defer ds2) = deferEval (ds1 `boths` ds2) +both d1@(Defer ds1) d2 = d2 `both` d1 + +boths = zipWithDmds both +\end{code} + + + +%************************************************************************ +%* * +\subsection{Miscellaneous +%* * +%************************************************************************ + + +\begin{code} +#ifdef OLD_STRICTNESS +get_changes binds = vcat (map get_changes_bind binds) + +get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs) +get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs) + +get_changes_pr (id,rhs) + = get_changes_var id $$ get_changes_expr rhs + +get_changes_var var + | isId var = get_changes_str var $$ get_changes_dmd var + | otherwise = empty + +get_changes_expr (Type t) = empty +get_changes_expr (Var v) = empty +get_changes_expr (Lit l) = empty +get_changes_expr (Note n e) = get_changes_expr e +get_changes_expr (App e1 e2) = get_changes_expr e1 $$ get_changes_expr e2 +get_changes_expr (Lam b e) = {- get_changes_var b $$ -} get_changes_expr e +get_changes_expr (Let b e) = get_changes_bind b $$ get_changes_expr e +get_changes_expr (Case e b a) = get_changes_expr e $$ {- get_changes_var b $$ -} vcat (map get_changes_alt a) + +get_changes_alt (con,bs,rhs) = {- vcat (map get_changes_var bs) $$ -} get_changes_expr rhs + +get_changes_str id + | new_better && old_better = empty + | new_better = message "BETTER" + | old_better = message "WORSE" + | otherwise = message "INCOMPARABLE" + where + message word = text word <+> text "strictness for" <+> ppr id <+> info + info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new) + new = squashSig (idNewStrictness id) -- Don't report spurious diffs that the old + -- strictness analyser can't track + old = newStrictnessFromOld (idName id) (idArity id) (idStrictness id) (idCprInfo id) + old_better = old `betterStrictness` new + new_better = new `betterStrictness` old + +get_changes_dmd id + | isUnLiftedType (idType id) = empty -- Not useful + | new_better && old_better = empty + | new_better = message "BETTER" + | old_better = message "WORSE" + | otherwise = message "INCOMPARABLE" + where + message word = text word <+> text "demand for" <+> ppr id <+> info + info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new) + new = squashDmd (argDemand (idNewDemandInfo id)) -- To avoid spurious improvements + -- A bit of a hack + old = newDemand (idDemandInfo id) + new_better = new `betterDemand` old + old_better = old `betterDemand` new + +betterStrictness :: StrictSig -> StrictSig -> Bool +betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2 + +betterDmdType t1 t2 = (t1 `lubType` t2) == t2 + +betterDemand :: Demand -> Demand -> Bool +-- If d1 `better` d2, and d2 `better` d2, then d1==d2 +betterDemand d1 d2 = (d1 `lub` d2) == d2 + +squashSig (StrictSig (DmdType fv ds res)) + = StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res) + where + -- squash just gets rid of call demands + -- which the old analyser doesn't track +squashDmd (Call d) = evalDmd +squashDmd (Box d) = Box (squashDmd d) +squashDmd (Eval ds) = Eval (mapDmds squashDmd ds) +squashDmd (Defer ds) = Defer (mapDmds squashDmd ds) +squashDmd d = d +#endif +\end{code} diff --git a/compiler/stranal/SaAbsInt.lhs b/compiler/stranal/SaAbsInt.lhs new file mode 100644 index 0000000000..a6a79ec166 --- /dev/null +++ b/compiler/stranal/SaAbsInt.lhs @@ -0,0 +1,925 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% +\section[SaAbsInt]{Abstract interpreter for strictness analysis} + +\begin{code} +#ifndef OLD_STRICTNESS +-- If OLD_STRICTNESS is off, omit all exports +module SaAbsInt () where + +#else +module SaAbsInt ( + findStrictness, + findDemand, findDemandAlts, + absEval, + widen, + fixpoint, + isBot + ) where + +#include "HsVersions.h" + +import StaticFlags ( opt_AllStrict, opt_NumbersStrict ) +import CoreSyn +import CoreUnfold ( maybeUnfoldingTemplate ) +import Id ( Id, idType, idUnfolding, isDataConWorkId_maybe, + idStrictness, + ) +import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys ) +import IdInfo ( StrictnessInfo(..) ) +import Demand ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy, + mkStrictnessInfo, isLazy + ) +import SaLib +import TyCon ( isProductTyCon, isRecursiveTyCon ) +import Type ( splitTyConApp_maybe, + isUnLiftedType, Type ) +import TyCon ( tyConUnique ) +import PrelInfo ( numericTyKeys ) +import Util ( isIn, nOfThem, zipWithEqual, equalLength ) +import Outputable +\end{code} + +%************************************************************************ +%* * +\subsection[AbsVal-ops]{Operations on @AbsVals@} +%* * +%************************************************************************ + +Least upper bound, greatest lower bound. + +\begin{code} +lub, glb :: AbsVal -> AbsVal -> AbsVal + +lub AbsBot val2 = val2 +lub val1 AbsBot = val1 + +lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "lub" lub xs ys) + +lub _ _ = AbsTop -- Crude, but conservative + -- The crudity only shows up if there + -- are functions involved + +-- Slightly funny glb; for absence analysis only; +-- AbsBot is the safe answer. +-- +-- Using anyBot rather than just testing for AbsBot is important. +-- Consider: +-- +-- f = \a b -> ... +-- +-- g = \x y z -> case x of +-- [] -> f x +-- (p:ps) -> f p +-- +-- Now, the abstract value of the branches of the case will be an +-- AbsFun, but when testing for z's absence we want to spot that it's +-- an AbsFun which can't possibly return AbsBot. So when glb'ing we +-- mustn't be too keen to bale out and return AbsBot; the anyBot test +-- spots that (f x) can't possibly return AbsBot. + +-- We have also tripped over the following interesting case: +-- case x of +-- [] -> \y -> 1 +-- (p:ps) -> f +-- +-- Now, suppose f is bound to AbsTop. Does this expression mention z? +-- Obviously not. But the case will take the glb of AbsTop (for f) and +-- an AbsFun (for \y->1). We should not bale out and give AbsBot, because +-- that would say that it *does* mention z (or anything else for that matter). +-- Nor can we always return AbsTop, because the AbsFun might be something +-- like (\y->z), which obviously does mention z. The point is that we're +-- glbing two functions, and AbsTop is not actually the top of the function +-- lattice. It is more like (\xyz -> x|y|z); that is, AbsTop returns +-- poison iff any of its arguments do. + +-- Deal with functions specially, because AbsTop isn't the +-- top of their domain. + +glb v1 v2 + | is_fun v1 || is_fun v2 + = if not (anyBot v1) && not (anyBot v2) + then + AbsTop + else + AbsBot + where + is_fun (AbsFun _ _) = True + is_fun (AbsApproxFun _ _) = True -- Not used, but the glb works ok + is_fun other = False + +-- The non-functional cases are quite straightforward + +glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "glb" glb xs ys) + +glb AbsTop v2 = v2 +glb v1 AbsTop = v1 + +glb _ _ = AbsBot -- Be pessimistic +\end{code} + +@isBot@ returns True if its argument is (a representation of) bottom. The +``representation'' part is because we need to detect the bottom {\em function} +too. To detect the bottom function, bind its args to top, and see if it +returns bottom. + +Used only in strictness analysis: +\begin{code} +isBot :: AbsVal -> Bool + +isBot AbsBot = True +isBot other = False -- Functions aren't bottom any more +\end{code} + +Used only in absence analysis: + +\begin{code} +anyBot :: AbsVal -> Bool + +anyBot AbsBot = True -- poisoned! +anyBot AbsTop = False +anyBot (AbsProd vals) = any anyBot vals +anyBot (AbsFun bndr_ty abs_fn) = anyBot (abs_fn AbsTop) +anyBot (AbsApproxFun _ val) = anyBot val +\end{code} + +@widen@ takes an @AbsVal@, $val$, and returns and @AbsVal@ which is +approximated by $val$. Furthermore, the result has no @AbsFun@s in +it, so it can be compared for equality by @sameVal@. + +\begin{code} +widen :: AnalysisKind -> AbsVal -> AbsVal + +-- Widening is complicated by the fact that funtions are lifted +widen StrAnal the_fn@(AbsFun bndr_ty _) + = case widened_body of + AbsApproxFun ds val -> AbsApproxFun (d : ds) val + where + d = findRecDemand str_fn abs_fn bndr_ty + str_fn val = isBot (foldl (absApply StrAnal) the_fn + (val : [AbsTop | d <- ds])) + + other -> AbsApproxFun [d] widened_body + where + d = findRecDemand str_fn abs_fn bndr_ty + str_fn val = isBot (absApply StrAnal the_fn val) + where + widened_body = widen StrAnal (absApply StrAnal the_fn AbsTop) + abs_fn val = False -- Always says poison; so it looks as if + -- nothing is absent; safe + +{- OLD comment... + This stuff is now instead handled neatly by the fact that AbsApproxFun + contains an AbsVal inside it. SLPJ Jan 97 + + | isBot abs_body = AbsBot + -- It's worth checking for a function which is unconditionally + -- bottom. Consider + -- + -- f x y = let g y = case x of ... + -- in (g ..) + (g ..) + -- + -- Here, when we are considering strictness of f in x, we'll + -- evaluate the body of f with x bound to bottom. The current + -- strategy is to bind g to its *widened* value; without the isBot + -- (...) test above, we'd bind g to an AbsApproxFun, and deliver + -- Top, not Bot as the value of f's rhs. The test spots the + -- unconditional bottom-ness of g when x is bottom. (Another + -- alternative here would be to bind g to its exact abstract + -- value, but that entails lots of potential re-computation, at + -- every application of g.) +-} + +widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals) +widen StrAnal other_val = other_val + + +widen AbsAnal the_fn@(AbsFun bndr_ty _) + | anyBot widened_body = AbsBot + -- In the absence-analysis case it's *essential* to check + -- that the function has no poison in its body. If it does, + -- anywhere, then the whole function is poisonous. + + | otherwise + = case widened_body of + AbsApproxFun ds val -> AbsApproxFun (d : ds) val + where + d = findRecDemand str_fn abs_fn bndr_ty + abs_fn val = not (anyBot (foldl (absApply AbsAnal) the_fn + (val : [AbsTop | d <- ds]))) + + other -> AbsApproxFun [d] widened_body + where + d = findRecDemand str_fn abs_fn bndr_ty + abs_fn val = not (anyBot (absApply AbsAnal the_fn val)) + where + widened_body = widen AbsAnal (absApply AbsAnal the_fn AbsTop) + str_fn val = True -- Always says non-termination; + -- that'll make findRecDemand peer into the + -- structure of the value. + +widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals) + + -- It's desirable to do a good job of widening for product + -- values. Consider + -- + -- let p = (x,y) + -- in ...(case p of (x,y) -> x)... + -- + -- Now, is y absent in this expression? Currently the + -- analyser widens p before looking at p's scope, to avoid + -- lots of recomputation in the case where p is a function. + -- So if widening doesn't have a case for products, we'll + -- widen p to AbsBot (since when searching for absence in y we + -- bind y to poison ie AbsBot), and now we are lost. + +widen AbsAnal other_val = other_val + +-- WAS: if anyBot val then AbsBot else AbsTop +-- Nowadays widen is doing a better job on functions for absence analysis. +\end{code} + +@crudeAbsWiden@ is used just for absence analysis, and always +returns AbsTop or AbsBot, so it widens to a two-point domain + +\begin{code} +crudeAbsWiden :: AbsVal -> AbsVal +crudeAbsWiden val = if anyBot val then AbsBot else AbsTop +\end{code} + +@sameVal@ compares two abstract values for equality. It can't deal with +@AbsFun@, but that should have been removed earlier in the day by @widen@. + +\begin{code} +sameVal :: AbsVal -> AbsVal -> Bool -- Can't handle AbsFun! + +#ifdef DEBUG +sameVal (AbsFun _ _) _ = panic "sameVal: AbsFun: arg1" +sameVal _ (AbsFun _ _) = panic "sameVal: AbsFun: arg2" +#endif + +sameVal AbsBot AbsBot = True +sameVal AbsBot other = False -- widen has reduced AbsFun bots to AbsBot + +sameVal AbsTop AbsTop = True +sameVal AbsTop other = False -- Right? + +sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual "sameVal" sameVal vals1 vals2) +sameVal (AbsProd _) AbsTop = False +sameVal (AbsProd _) AbsBot = False + +sameVal (AbsApproxFun str1 v1) (AbsApproxFun str2 v2) = str1 == str2 && sameVal v1 v2 +sameVal (AbsApproxFun _ _) AbsTop = False +sameVal (AbsApproxFun _ _) AbsBot = False + +sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered" +\end{code} + + +@evalStrictness@ compares a @Demand@ with an abstract value, returning +@True@ iff the abstract value is {\em less defined} than the demand. +(@True@ is the exciting answer; @False@ is always safe.) + +\begin{code} +evalStrictness :: Demand + -> AbsVal + -> Bool -- True iff the value is sure + -- to be less defined than the Demand + +evalStrictness (WwLazy _) _ = False +evalStrictness WwStrict val = isBot val +evalStrictness WwEnum val = isBot val + +evalStrictness (WwUnpack _ demand_info) val + = case val of + AbsTop -> False + AbsBot -> True + AbsProd vals + | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalStrictness" (ppr demand_info $$ ppr val) + False + | otherwise -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals) + + _ -> pprTrace "evalStrictness?" empty False + +evalStrictness WwPrim val + = case val of + AbsTop -> False + AbsBot -> True -- Can happen: consider f (g x), where g is a + -- recursive function returning an Int# that diverges + + other -> pprPanic "evalStrictness: WwPrim:" (ppr other) +\end{code} + +For absence analysis, we're interested in whether "poison" in the +argument (ie a bottom therein) can propagate to the result of the +function call; that is, whether the specified demand can {\em +possibly} hit poison. + +\begin{code} +evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison + -- with Absent demand + +evalAbsence (WwUnpack _ demand_info) val + = case val of + AbsTop -> False -- No poison in here + AbsBot -> True -- Pure poison + AbsProd vals + | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalAbsence" (ppr demand_info $$ ppr val) + True + | otherwise -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals) + _ -> pprTrace "TELL SIMON: evalAbsence" + (ppr demand_info $$ ppr val) + True + +evalAbsence other val = anyBot val + -- The demand is conservative; even "Lazy" *might* evaluate the + -- argument arbitrarily so we have to look everywhere for poison +\end{code} + +%************************************************************************ +%* * +\subsection[absEval]{Evaluate an expression in the abstract domain} +%* * +%************************************************************************ + +\begin{code} +-- The isBottomingId stuf is now dealt with via the Id's strictness info +-- absId anal var env | isBottomingId var +-- = case anal of +-- StrAnal -> AbsBot -- See discussion below +-- AbsAnal -> AbsTop -- Just want to see if there's any poison in + -- error's arg + +absId anal var env + = case (lookupAbsValEnv env var, + isDataConWorkId_maybe var, + idStrictness var, + maybeUnfoldingTemplate (idUnfolding var)) of + + (Just abs_val, _, _, _) -> + abs_val -- Bound in the environment + + (_, Just data_con, _, _) | isProductTyCon tycon && + not (isRecursiveTyCon tycon) + -> -- A product. We get infinite loops if we don't + -- check for recursive products! + -- The strictness info on the constructor + -- isn't expressive enough to contain its abstract value + productAbsVal (dataConRepArgTys data_con) [] + where + tycon = dataConTyCon data_con + + (_, _, NoStrictnessInfo, Just unfolding) -> + -- We have an unfolding for the expr + -- Assume the unfolding has no free variables since it + -- came from inside the Id + absEval anal unfolding env + -- Notice here that we only look in the unfolding if we don't + -- have strictness info (an unusual situation). + -- We could have chosen to look in the unfolding if it exists, + -- and only try the strictness info if it doesn't, and that would + -- give more accurate results, at the cost of re-abstract-interpreting + -- the unfolding every time. + -- We found only one place where the look-at-unfolding-first + -- method gave better results, which is in the definition of + -- showInt in the Prelude. In its defintion, fromIntegral is + -- not inlined (it's big) but ab-interp-ing its unfolding gave + -- a better result than looking at its strictness only. + -- showInt :: Integral a => a -> [Char] -> [Char] + -- ! {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_ + -- "U(U(U(U(SA)AAAAAAAAL)AA)AAAAASAAASA)" {...} _N_ _N_ #-} + -- --- 42,44 ---- + -- showInt :: Integral a => a -> [Char] -> [Char] + -- ! {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_ + -- "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-} + + + (_, _, strictness_info, _) -> + -- Includes NoUnfolding + -- Try the strictness info + absValFromStrictness anal strictness_info + +productAbsVal [] rev_abs_args = AbsProd (reverse rev_abs_args) +productAbsVal (arg_ty : arg_tys) rev_abs_args = AbsFun arg_ty (\ abs_arg -> productAbsVal arg_tys (abs_arg : rev_abs_args)) +\end{code} + +\begin{code} +absEval :: AnalysisKind -> CoreExpr -> AbsValEnv -> AbsVal + +absEval anal (Type ty) env = AbsTop +absEval anal (Var var) env = absId anal var env +\end{code} + +Discussion about error (following/quoting Lennart): Any expression +'error e' is regarded as bottom (with HBC, with the -ffail-strict +flag, on with -O). + +Regarding it as bottom gives much better strictness properties for +some functions. E.g. + + f [x] y = x+y + f (x:xs) y = f xs (x+y) +i.e. + f [] _ = error "no match" + f [x] y = x+y + f (x:xs) y = f xs (x+y) + +is strict in y, which you really want. But, it may lead to +transformations that turn a call to \tr{error} into non-termination. +(The odds of this happening aren't good.) + +Things are a little different for absence analysis, because we want +to make sure that any poison (?????) + +\begin{code} +absEval anal (Lit _) env = AbsTop + -- Literals terminate (strictness) and are not poison (absence) +\end{code} + +\begin{code} +absEval anal (Lam bndr body) env + | isTyVar bndr = absEval anal body env -- Type lambda + | otherwise = AbsFun (idType bndr) abs_fn -- Value lambda + where + abs_fn arg = absEval anal body (addOneToAbsValEnv env bndr arg) + +absEval anal (App expr (Type ty)) env + = absEval anal expr env -- Type appplication +absEval anal (App f val_arg) env + = absApply anal (absEval anal f env) -- Value applicationn + (absEval anal val_arg env) +\end{code} + +\begin{code} +absEval anal expr@(Case scrut case_bndr alts) env + = let + scrut_val = absEval anal scrut env + alts_env = addOneToAbsValEnv env case_bndr scrut_val + in + case (scrut_val, alts) of + (AbsBot, _) -> AbsBot + + (AbsProd arg_vals, [(con, bndrs, rhs)]) + | con /= DEFAULT -> + -- The scrutinee is a product value, so it must be of a single-constr + -- type; so the constructor in this alternative must be the right one + -- so we can go ahead and bind the constructor args to the components + -- of the product value. + ASSERT(equalLength arg_vals val_bndrs) + absEval anal rhs rhs_env + where + val_bndrs = filter isId bndrs + rhs_env = growAbsValEnvList alts_env (val_bndrs `zip` arg_vals) + + other -> absEvalAlts anal alts alts_env +\end{code} + +For @Lets@ we widen the value we get. This is nothing to +do with fixpointing. The reason is so that we don't get an explosion +in the amount of computation. For example, consider: +\begin{verbatim} + let + g a = case a of + q1 -> ... + q2 -> ... + f x = case x of + p1 -> ...g r... + p2 -> ...g s... + in + f e +\end{verbatim} +If we bind @f@ and @g@ to their exact abstract value, then we'll +``execute'' one call to @f@ and {\em two} calls to @g@. This can blow +up exponentially. Widening cuts it off by making a fixed +approximation to @f@ and @g@, so that the bodies of @f@ and @g@ are +not evaluated again at all when they are called. + +Of course, this can lose useful joint strictness, which is sad. An +alternative approach would be to try with a certain amount of ``fuel'' +and be prepared to bale out. + +\begin{code} +absEval anal (Let (NonRec binder e1) e2) env + = let + new_env = addOneToAbsValEnv env binder (widen anal (absEval anal e1 env)) + in + -- The binder of a NonRec should *not* be of unboxed type, + -- hence no need to strictly evaluate the Rhs. + absEval anal e2 new_env + +absEval anal (Let (Rec pairs) body) env + = let + (binders,rhss) = unzip pairs + rhs_vals = cheapFixpoint anal binders rhss env -- Returns widened values + new_env = growAbsValEnvList env (binders `zip` rhs_vals) + in + absEval anal body new_env + +absEval anal (Note (Coerce _ _) expr) env = AbsTop + -- Don't look inside coerces, becuase they + -- are usually recursive newtypes + -- (Could improve, for the error case, but we're about + -- to kill this analyser anyway.) +absEval anal (Note note expr) env = absEval anal expr env +\end{code} + +\begin{code} +absEvalAlts :: AnalysisKind -> [CoreAlt] -> AbsValEnv -> AbsVal +absEvalAlts anal alts env + = combine anal (map go alts) + where + combine StrAnal = foldr1 lub -- Diverge only if all diverge + combine AbsAnal = foldr1 glb -- Find any poison + + go (con, bndrs, rhs) + = absEval anal rhs rhs_env + where + rhs_env = growAbsValEnvList env (filter isId bndrs `zip` repeat AbsTop) +\end{code} + +%************************************************************************ +%* * +\subsection[absApply]{Apply an abstract function to an abstract argument} +%* * +%************************************************************************ + +Easy ones first: + +\begin{code} +absApply :: AnalysisKind -> AbsVal -> AbsVal -> AbsVal + +absApply anal AbsBot arg = AbsBot + -- AbsBot represents the abstract bottom *function* too + +absApply StrAnal AbsTop arg = AbsTop +absApply AbsAnal AbsTop arg = if anyBot arg + then AbsBot + else AbsTop + -- To be conservative, we have to assume that a function about + -- which we know nothing (AbsTop) might look at some part of + -- its argument +\end{code} + +An @AbsFun@ with only one more argument needed---bind it and eval the +result. A @Lam@ with two or more args: return another @AbsFun@ with +an augmented environment. + +\begin{code} +absApply anal (AbsFun bndr_ty abs_fn) arg = abs_fn arg +\end{code} + +\begin{code} +absApply StrAnal (AbsApproxFun (d:ds) val) arg + = case ds of + [] -> val' + other -> AbsApproxFun ds val' -- Result is non-bot if there are still args + where + val' | evalStrictness d arg = AbsBot + | otherwise = val + +absApply AbsAnal (AbsApproxFun (d:ds) val) arg + = if evalAbsence d arg + then AbsBot -- Poison in arg means poison in the application + else case ds of + [] -> val + other -> AbsApproxFun ds val + +#ifdef DEBUG +absApply anal f@(AbsProd _) arg + = pprPanic ("absApply: Duff function: AbsProd." ++ show anal) ((ppr f) <+> (ppr arg)) +#endif +\end{code} + + + + +%************************************************************************ +%* * +\subsection[findStrictness]{Determine some binders' strictness} +%* * +%************************************************************************ + +\begin{code} +findStrictness :: Id + -> AbsVal -- Abstract strictness value of function + -> AbsVal -- Abstract absence value of function + -> StrictnessInfo -- Resulting strictness annotation + +findStrictness id (AbsApproxFun str_ds str_res) (AbsApproxFun abs_ds _) + -- You might think there's really no point in describing detailed + -- strictness for a divergent function; + -- If it's fully applied we get bottom regardless of the + -- argument. If it's not fully applied we don't get bottom. + -- Finally, we don't want to regard the args of a divergent function + -- as 'interesting' for inlining purposes (see Simplify.prepareArgs) + -- + -- HOWEVER, if we make diverging functions appear lazy, they + -- don't get wrappers, and then we get dreadful reboxing. + -- See notes with WwLib.worthSplitting + = find_strictness id str_ds str_res abs_ds + +findStrictness id str_val abs_val + | isBot str_val = mkStrictnessInfo ([], True) + | otherwise = NoStrictnessInfo + +-- The list of absence demands passed to combineDemands +-- can be shorter than the list of absence demands +-- +-- lookup = \ dEq -> letrec { +-- lookup = \ key ds -> ...lookup... +-- } +-- in lookup +-- Here the strictness value takes three args, but the absence value +-- takes only one, for reasons I don't quite understand (see cheapFixpoint) + +find_strictness id orig_str_ds orig_str_res orig_abs_ds + = mkStrictnessInfo (go orig_str_ds orig_abs_ds, res_bot) + where + res_bot = isBot orig_str_res + + go str_ds abs_ds = zipWith mk_dmd str_ds (abs_ds ++ repeat wwLazy) + + mk_dmd str_dmd (WwLazy True) + = WARN( not (res_bot || isLazy str_dmd), + ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds ) + -- If the arg isn't used we jolly well don't expect the function + -- to be strict in it. Unless the function diverges. + WwLazy True -- Best of all + + mk_dmd (WwUnpack u str_ds) + (WwUnpack _ abs_ds) = WwUnpack u (go str_ds abs_ds) + + mk_dmd str_dmd abs_dmd = str_dmd +\end{code} + + +\begin{code} +findDemand dmd str_env abs_env expr binder + = findRecDemand str_fn abs_fn (idType binder) + where + str_fn val = evalStrictness dmd (absEval StrAnal expr (addOneToAbsValEnv str_env binder val)) + abs_fn val = not (evalAbsence dmd (absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val))) + +findDemandAlts dmd str_env abs_env alts binder + = findRecDemand str_fn abs_fn (idType binder) + where + str_fn val = evalStrictness dmd (absEvalAlts StrAnal alts (addOneToAbsValEnv str_env binder val)) + abs_fn val = not (evalAbsence dmd (absEvalAlts AbsAnal alts (addOneToAbsValEnv abs_env binder val))) +\end{code} + +@findRecDemand@ is where we finally convert strictness/absence info +into ``Demands'' which we can pin on Ids (etc.). + +NOTE: What do we do if something is {\em both} strict and absent? +Should \tr{f x y z = error "foo"} says that \tr{f}'s arguments are all +strict (because of bottoming effect of \tr{error}) or all absent +(because they're not used)? + +Well, for practical reasons, we prefer absence over strictness. In +particular, it makes the ``default defaults'' for class methods (the +ones that say \tr{defm.foo dict = error "I don't exist"}) come out +nicely [saying ``the dict isn't used''], rather than saying it is +strict in every component of the dictionary [massive gratuitious +casing to take the dict apart]. + +But you could have examples where going for strictness would be better +than absence. Consider: +\begin{verbatim} + let x = something big + in + f x y z + g x +\end{verbatim} + +If \tr{x} is marked absent in \tr{f}, but not strict, and \tr{g} is +lazy, then the thunk for \tr{x} will be built. If \tr{f} was strict, +then we'd let-to-case it: +\begin{verbatim} + case something big of + x -> f x y z + g x +\end{verbatim} +Ho hum. + +\begin{code} +findRecDemand :: (AbsVal -> Bool) -- True => function applied to this value yields Bot + -> (AbsVal -> Bool) -- True => function applied to this value yields no poison + -> Type -- The type of the argument + -> Demand + +findRecDemand str_fn abs_fn ty + = if isUnLiftedType ty then -- It's a primitive type! + wwPrim + + else if abs_fn AbsBot then -- It's absent + -- We prefer absence over strictness: see NOTE above. + WwLazy True + + else if not (opt_AllStrict || + (opt_NumbersStrict && is_numeric_type ty) || + str_fn AbsBot) then + WwLazy False -- It's not strict and we're not pretending + + else -- It's strict (or we're pretending it is)! + + case splitProductType_maybe ty of + + Nothing -> wwStrict -- Could have a test for wwEnum, but + -- we don't exploit it yet, so don't bother + + Just (tycon,_,data_con,cmpnt_tys) -- Single constructor case + | isRecursiveTyCon tycon -- Recursive data type; don't unpack + -> wwStrict -- (this applies to newtypes too: + -- e.g. data Void = MkVoid Void) + + | null compt_strict_infos -- A nullary data type + -> wwStrict + + | otherwise -- Some other data type + -> wwUnpack compt_strict_infos + + where + prod_len = length cmpnt_tys + compt_strict_infos + = [ findRecDemand + (\ cmpnt_val -> + str_fn (mkMainlyTopProd prod_len i cmpnt_val) + ) + (\ cmpnt_val -> + abs_fn (mkMainlyTopProd prod_len i cmpnt_val) + ) + cmpnt_ty + | (cmpnt_ty, i) <- cmpnt_tys `zip` [1..] ] + + where + is_numeric_type ty + = case (splitTyConApp_maybe ty) of -- NB: duplicates stuff done above + Nothing -> False + Just (tycon, _) -> tyConUnique tycon `is_elem` numericTyKeys + where + is_elem = isIn "is_numeric_type" + + -- mkMainlyTopProd: make an AbsProd that is all AbsTops ("n"-1 of + -- them) except for a given value in the "i"th position. + + mkMainlyTopProd :: Int -> Int -> AbsVal -> AbsVal + + mkMainlyTopProd n i val + = let + befores = nOfThem (i-1) AbsTop + afters = nOfThem (n-i) AbsTop + in + AbsProd (befores ++ (val : afters)) +\end{code} + +%************************************************************************ +%* * +\subsection[fixpoint]{Fixpointer for the strictness analyser} +%* * +%************************************************************************ + +The @fixpoint@ functions take a list of \tr{(binder, expr)} pairs, an +environment, and returns the abstract value of each binder. + +The @cheapFixpoint@ function makes a conservative approximation, +by binding each of the variables to Top in their own right hand sides. +That allows us to make rapid progress, at the cost of a less-than-wonderful +approximation. + +\begin{code} +cheapFixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal] + +cheapFixpoint AbsAnal [id] [rhs] env + = [crudeAbsWiden (absEval AbsAnal rhs new_env)] + where + new_env = addOneToAbsValEnv env id AbsTop -- Unsafe starting point! + -- In the just-one-binding case, we guarantee to + -- find a fixed point in just one iteration, + -- because we are using only a two-point domain. + -- This improves matters in cases like: + -- + -- f x y = letrec g = ...g... + -- in g x + -- + -- Here, y isn't used at all, but if g is bound to + -- AbsBot we simply get AbsBot as the next + -- iteration too. + +cheapFixpoint anal ids rhss env + = [widen anal (absEval anal rhs new_env) | rhs <- rhss] + -- We do just one iteration, starting from a safe + -- approximation. This won't do a good job in situations + -- like: + -- \x -> letrec f = ...g... + -- g = ...f...x... + -- in + -- ...f... + -- Here, f will end up bound to Top after one iteration, + -- and hence we won't spot the strictness in x. + -- (A second iteration would solve this. ToDo: try the effect of + -- really searching for a fixed point.) + where + new_env = growAbsValEnvList env [(id,safe_val) | id <- ids] + + safe_val + = case anal of -- The safe starting point + StrAnal -> AbsTop + AbsAnal -> AbsBot +\end{code} + +\begin{code} +fixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal] + +fixpoint anal [] _ env = [] + +fixpoint anal ids rhss env + = fix_loop initial_vals + where + initial_val id + = case anal of -- The (unsafe) starting point + AbsAnal -> AbsTop + StrAnal -> AbsBot + -- At one stage for StrAnal we said: + -- if (returnsRealWorld (idType id)) + -- then AbsTop -- this is a massively horrible hack (SLPJ 95/05) + -- but no one has the foggiest idea what this hack did, + -- and returnsRealWorld was a stub that always returned False + -- So this comment is all that is left of the hack! + + initial_vals = [ initial_val id | id <- ids ] + + fix_loop :: [AbsVal] -> [AbsVal] + + fix_loop current_widened_vals + = let + new_env = growAbsValEnvList env (ids `zip` current_widened_vals) + new_vals = [ absEval anal rhs new_env | rhs <- rhss ] + new_widened_vals = map (widen anal) new_vals + in + if (and (zipWith sameVal current_widened_vals new_widened_vals)) then + current_widened_vals + + -- NB: I was too chicken to make that a zipWithEqual, + -- lest I jump into a black hole. WDP 96/02 + + -- Return the widened values. We might get a slightly + -- better value by returning new_vals (which we used to + -- do, see below), but alas that means that whenever the + -- function is called we have to re-execute it, which is + -- expensive. + + -- OLD VERSION + -- new_vals + -- Return the un-widened values which may be a bit better + -- than the widened ones, and are guaranteed safe, since + -- they are one iteration beyond current_widened_vals, + -- which itself is a fixed point. + else + fix_loop new_widened_vals +\end{code} + +For absence analysis, we make do with a very very simple approach: +look for convergence in a two-point domain. + +We used to use just one iteration, starting with the variables bound +to @AbsBot@, which is safe. + +Prior to that, we used one iteration starting from @AbsTop@ (which +isn't safe). Why isn't @AbsTop@ safe? Consider: +\begin{verbatim} + letrec + x = ...p..d... + d = (x,y) + in + ... +\end{verbatim} +Here, if p is @AbsBot@, then we'd better {\em not} end up with a ``fixed +point'' of @d@ being @(AbsTop, AbsTop)@! An @AbsBot@ initial value is +safe because it gives poison more often than really necessary, and +thus may miss some absence, but will never claim absence when it ain't +so. + +Anyway, one iteration starting with everything bound to @AbsBot@ give +bad results for + + f = \ x -> ...f... + +Here, f would always end up bound to @AbsBot@, which ain't very +clever, because then it would introduce poison whenever it was +applied. Much better to start with f bound to @AbsTop@, and widen it +to @AbsBot@ if any poison shows up. In effect we look for convergence +in the two-point @AbsTop@/@AbsBot@ domain. + +What we miss (compared with the cleverer strictness analysis) is +spotting that in this case + + f = \ x y -> ...y...(f x y')... + +\tr{x} is actually absent, since it is only passed round the loop, never +used. But who cares about missing that? + +NB: despite only having a two-point domain, we may still have many +iterations, because there are several variables involved at once. + +\begin{code} +#endif /* OLD_STRICTNESS */ +\end{code} diff --git a/compiler/stranal/SaLib.lhs b/compiler/stranal/SaLib.lhs new file mode 100644 index 0000000000..338a351530 --- /dev/null +++ b/compiler/stranal/SaLib.lhs @@ -0,0 +1,130 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% +\section[SaLib]{Basic datatypes, functions for the strictness analyser} + +See also: the ``library'' for the ``back end'' (@SaBackLib@). + +\begin{code} +#ifndef OLD_STRICTNESS +module SaLib () where +#else + +module SaLib ( + AbsVal(..), + AnalysisKind(..), + AbsValEnv{-abstract-}, StrictEnv, AbsenceEnv, + mkAbsApproxFun, + nullAbsValEnv, addOneToAbsValEnv, growAbsValEnvList, + lookupAbsValEnv, + absValFromStrictness + ) where + +#include "HsVersions.h" + +import Type ( Type ) +import VarEnv +import IdInfo ( StrictnessInfo(..) ) +import Demand ( Demand ) +import Outputable +\end{code} + +%************************************************************************ +%* * +\subsection[AbsVal-datatype]{@AbsVal@: abstract values (and @AbsValEnv@)} +%* * +%************************************************************************ + +@AnalysisKind@ tells what kind of analysis is being done. + +\begin{code} +data AnalysisKind + = StrAnal -- We're doing strictness analysis + | AbsAnal -- We're doing absence analysis + deriving Show +\end{code} + +@AbsVal@ is the data type of HNF abstract values. + +\begin{code} +data AbsVal + = AbsTop -- AbsTop is the completely uninformative + -- value + + | AbsBot -- An expression whose abstract value is + -- AbsBot is sure to fail to terminate. + -- AbsBot represents the abstract + -- *function* bottom too. + + | AbsProd [AbsVal] -- (Lifted) product of abstract values + -- "Lifted" means that AbsBot is *different* from + -- AbsProd [AbsBot, ..., AbsBot] + + | AbsFun -- An abstract function, with the given: + Type -- Type of the *argument* to the function + (AbsVal -> AbsVal) -- The function + + | AbsApproxFun -- This is used to represent a coarse + [Demand] -- approximation to a function value. It's an + AbsVal -- abstract function which is strict in its + -- arguments if the Demand so indicates. + -- INVARIANT: the [Demand] is non-empty + + -- AbsApproxFun has to take a *list* of demands, no just one, + -- because function spaces are now lifted. Hence, (f bot top) + -- might be bot, but the partial application (f bot) is a *function*, + -- not bot. + +mkAbsApproxFun :: Demand -> AbsVal -> AbsVal +mkAbsApproxFun d (AbsApproxFun ds val) = AbsApproxFun (d:ds) val +mkAbsApproxFun d val = AbsApproxFun [d] val + +instance Outputable AbsVal where + ppr AbsTop = ptext SLIT("AbsTop") + ppr AbsBot = ptext SLIT("AbsBot") + ppr (AbsProd prod) = hsep [ptext SLIT("AbsProd"), ppr prod] + ppr (AbsFun bndr_ty body) = ptext SLIT("AbsFun") + ppr (AbsApproxFun demands val) + = ptext SLIT("AbsApprox") <+> brackets (interpp'SP demands) <+> ppr val +\end{code} + +%----------- + +An @AbsValEnv@ maps @Ids@ to @AbsVals@. Any unbound @Ids@ are +implicitly bound to @AbsTop@, the completely uninformative, +pessimistic value---see @absEval@ of a @Var@. + +\begin{code} +newtype AbsValEnv = AbsValEnv (IdEnv AbsVal) + +type StrictEnv = AbsValEnv -- Environment for strictness analysis +type AbsenceEnv = AbsValEnv -- Environment for absence analysis + +nullAbsValEnv -- this is the one and only way to create AbsValEnvs + = AbsValEnv emptyVarEnv + +addOneToAbsValEnv (AbsValEnv idenv) y z = AbsValEnv (extendVarEnv idenv y z) +growAbsValEnvList (AbsValEnv idenv) ys = AbsValEnv (extendVarEnvList idenv ys) + +lookupAbsValEnv (AbsValEnv idenv) y + = lookupVarEnv idenv y +\end{code} + +\begin{code} +absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal + +absValFromStrictness anal NoStrictnessInfo = AbsTop +absValFromStrictness anal (StrictnessInfo args_info bot_result) + = case args_info of -- Check the invariant that the arg list on + [] -> res -- AbsApproxFun is non-empty + _ -> AbsApproxFun args_info res + where + res | not bot_result = AbsTop + | otherwise = case anal of + StrAnal -> AbsBot + AbsAnal -> AbsTop +\end{code} + +\begin{code} +#endif /* OLD_STRICTNESS */ +\end{code} diff --git a/compiler/stranal/StrictAnal.lhs b/compiler/stranal/StrictAnal.lhs new file mode 100644 index 0000000000..242a947074 --- /dev/null +++ b/compiler/stranal/StrictAnal.lhs @@ -0,0 +1,494 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% +\section[StrictAnal]{``Simple'' Mycroft-style strictness analyser} + +The original version(s) of all strictness-analyser code (except the +Semantique analyser) was written by Andy Gill. + +\begin{code} +#ifndef OLD_STRICTNESS +module StrictAnal ( ) where + +#else + +module StrictAnal ( saBinds ) where + +#include "HsVersions.h" + +import DynFlags ( DynFlags, DynFlag(..) ) +import CoreSyn +import Id ( setIdStrictness, setInlinePragma, + idDemandInfo, setIdDemandInfo, isBottomingId, + Id + ) +import CoreLint ( showPass, endPass ) +import ErrUtils ( dumpIfSet_dyn ) +import SaAbsInt +import SaLib +import Demand ( Demand, wwStrict, isStrict, isLazy ) +import Util ( zipWith3Equal, stretchZipWith, compareLength ) +import BasicTypes ( Activation( NeverActive ) ) +import Outputable +import FastTypes +\end{code} + +%************************************************************************ +%* * +\subsection[Thoughts]{Random thoughts} +%* * +%************************************************************************ + +A note about worker-wrappering. If we have + + f :: Int -> Int + f = let v = <expensive> + in \x -> <body> + +and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to + + f = \x -> case x of Int x# -> fw x# + fw = \x# -> let x = Int x# + in + let v = <expensive> + in <body> + +because this obviously loses laziness, since now <expensive> +is done each time. Alas. + +WATCH OUT! This can mean that something is unboxed only to be +boxed again. For example + + g x y = f x + +Here g is strict, and *will* split into worker-wrapper. A call to +g, with the wrapper inlined will then be + + case arg of Int a# -> gw a# + +Now g calls f, which has no wrapper, so it has to box it. + + gw = \a# -> f (Int a#) + +Alas and alack. + + +%************************************************************************ +%* * +\subsection[iface-StrictAnal]{Interface to the outside world} +%* * +%************************************************************************ + +@saBinds@ decorates bindings with strictness info. A later +worker-wrapper pass can use this info to create wrappers and +strict workers. + +\begin{code} +saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind] +saBinds dflags binds + = do { + showPass dflags "Strictness analysis"; + + -- Mark each binder with its strictness +#ifndef OMIT_STRANAL_STATS + let { (binds_w_strictness, sa_stats) = saTopBinds binds nullSaStats }; + dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Strictness analysis statistics" + (pp_stats sa_stats); +#else + let { binds_w_strictness = saTopBindsBinds binds }; +#endif + + endPass dflags "Strictness analysis" Opt_D_dump_stranal + binds_w_strictness + } +\end{code} + +%************************************************************************ +%* * +\subsection[saBinds]{Strictness analysis of bindings} +%* * +%************************************************************************ + +[Some of the documentation about types, etc., in \tr{SaLib} may be +helpful for understanding this module.] + +@saTopBinds@ tags each binder in the program with its @Demand@. +That tells how each binder is {\em used}; if @Strict@, then the binder +is sure to be evaluated to HNF; if @NonStrict@ it may or may not be; +if @Absent@, then it certainly is not used. [DATED; ToDo: update] + +(The above info is actually recorded for posterity in each binder's +IdInfo, notably its @DemandInfo@.) + +We proceed by analysing the bindings top-to-bottom, building up an +environment which maps @Id@s to their abstract values (i.e., an +@AbsValEnv@ maps an @Id@ to its @AbsVal@). + +\begin{code} +saTopBinds :: [CoreBind] -> SaM [CoreBind] -- not exported + +saTopBinds binds + = let + starting_abs_env = nullAbsValEnv + in + do_it starting_abs_env starting_abs_env binds + where + do_it _ _ [] = returnSa [] + do_it senv aenv (b:bs) + = saTopBind senv aenv b `thenSa` \ (senv2, aenv2, new_b) -> + do_it senv2 aenv2 bs `thenSa` \ new_bs -> + returnSa (new_b : new_bs) +\end{code} + +@saTopBind@ is only used for the top level. We don't add any demand +info to these ids because we can't work it out. In any case, it +doesn't do us any good to know whether top-level binders are sure to +be used; we can't turn top-level @let@s into @case@s. + +\begin{code} +saTopBind :: StrictEnv -> AbsenceEnv + -> CoreBind + -> SaM (StrictEnv, AbsenceEnv, CoreBind) + +saTopBind str_env abs_env (NonRec binder rhs) + = saExpr minDemand str_env abs_env rhs `thenSa` \ new_rhs -> + let + str_rhs = absEval StrAnal rhs str_env + abs_rhs = absEval AbsAnal rhs abs_env + + widened_str_rhs = widen StrAnal str_rhs + widened_abs_rhs = widen AbsAnal abs_rhs + -- The widening above is done for efficiency reasons. + -- See notes on Let case in SaAbsInt.lhs + + new_binder + = addStrictnessInfoToTopId + widened_str_rhs widened_abs_rhs + binder + + -- Augment environments with a mapping of the + -- binder to its abstract values, computed by absEval + new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs + new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs + in + returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs) + +saTopBind str_env abs_env (Rec pairs) + = let + (binders,rhss) = unzip pairs + str_rhss = fixpoint StrAnal binders rhss str_env + abs_rhss = fixpoint AbsAnal binders rhss abs_env + -- fixpoint returns widened values + new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss) + new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss) + new_binders = zipWith3Equal "saTopBind" addStrictnessInfoToTopId + str_rhss abs_rhss binders + in + mapSa (saExpr minDemand new_str_env new_abs_env) rhss `thenSa` \ new_rhss -> + let + new_pairs = new_binders `zip` new_rhss + in + returnSa (new_str_env, new_abs_env, Rec new_pairs) + +-- Hack alert! +-- Top level divergent bindings are marked NOINLINE +-- This avoids fruitless inlining of top level error functions +addStrictnessInfoToTopId str_val abs_val bndr + = if isBottomingId new_id then + new_id `setInlinePragma` NeverActive + else + new_id + where + new_id = addStrictnessInfoToId str_val abs_val bndr +\end{code} + +%************************************************************************ +%* * +\subsection[saExpr]{Strictness analysis of an expression} +%* * +%************************************************************************ + +@saExpr@ computes the strictness of an expression within a given +environment. + +\begin{code} +saExpr :: Demand -> StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr + -- The demand is the least demand we expect on the + -- expression. WwStrict is the least, because we're only + -- interested in the expression at all if it's being evaluated, + -- but the demand may be more. E.g. + -- f E + -- where f has strictness u(LL), will evaluate E with demand u(LL) + +minDemand = wwStrict +minDemands = repeat minDemand + +-- When we find an application, do the arguments +-- with demands gotten from the function +saApp str_env abs_env (fun, args) + = sequenceSa sa_args `thenSa` \ args' -> + saExpr minDemand str_env abs_env fun `thenSa` \ fun' -> + returnSa (mkApps fun' args') + where + arg_dmds = case fun of + Var var -> case lookupAbsValEnv str_env var of + Just (AbsApproxFun ds _) + | compareLength ds args /= LT + -- 'ds' is at least as long as 'args'. + -> ds ++ minDemands + other -> minDemands + other -> minDemands + + sa_args = stretchZipWith isTypeArg (error "saApp:dmd") + sa_arg args arg_dmds + -- The arg_dmds are for value args only, we need to skip + -- over the type args when pairing up with the demands + -- Hence the stretchZipWith + + sa_arg arg dmd = saExpr dmd' str_env abs_env arg + where + -- Bring arg demand up to minDemand + dmd' | isLazy dmd = minDemand + | otherwise = dmd + +saExpr _ _ _ e@(Var _) = returnSa e +saExpr _ _ _ e@(Lit _) = returnSa e +saExpr _ _ _ e@(Type _) = returnSa e + +saExpr dmd str_env abs_env (Lam bndr body) + = -- Don't bother to set the demand-info on a lambda binder + -- We do that only for let(rec)-bound functions + saExpr minDemand str_env abs_env body `thenSa` \ new_body -> + returnSa (Lam bndr new_body) + +saExpr dmd str_env abs_env e@(App fun arg) + = saApp str_env abs_env (collectArgs e) + +saExpr dmd str_env abs_env (Note note expr) + = saExpr dmd str_env abs_env expr `thenSa` \ new_expr -> + returnSa (Note note new_expr) + +saExpr dmd str_env abs_env (Case expr case_bndr alts) + = saExpr minDemand str_env abs_env expr `thenSa` \ new_expr -> + mapSa sa_alt alts `thenSa` \ new_alts -> + let + new_case_bndr = addDemandInfoToCaseBndr dmd str_env abs_env alts case_bndr + in + returnSa (Case new_expr new_case_bndr new_alts) + where + sa_alt (con, binders, rhs) + = saExpr dmd str_env abs_env rhs `thenSa` \ new_rhs -> + let + new_binders = map add_demand_info binders + add_demand_info bndr | isTyVar bndr = bndr + | otherwise = addDemandInfoToId dmd str_env abs_env rhs bndr + in + tickCases new_binders `thenSa_` -- stats + returnSa (con, new_binders, new_rhs) + +saExpr dmd str_env abs_env (Let (NonRec binder rhs) body) + = -- Analyse the RHS in the environment at hand + let + -- Find the demand on the RHS + rhs_dmd = findDemand dmd str_env abs_env body binder + + -- Bind this binder to the abstract value of the RHS; analyse + -- the body of the `let' in the extended environment. + str_rhs_val = absEval StrAnal rhs str_env + abs_rhs_val = absEval AbsAnal rhs abs_env + + widened_str_rhs = widen StrAnal str_rhs_val + widened_abs_rhs = widen AbsAnal abs_rhs_val + -- The widening above is done for efficiency reasons. + -- See notes on Let case in SaAbsInt.lhs + + new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs + new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs + + -- Now determine the strictness of this binder; use that info + -- to record DemandInfo/StrictnessInfo in the binder. + new_binder = addStrictnessInfoToId + widened_str_rhs widened_abs_rhs + (binder `setIdDemandInfo` rhs_dmd) + in + tickLet new_binder `thenSa_` -- stats + saExpr rhs_dmd str_env abs_env rhs `thenSa` \ new_rhs -> + saExpr dmd new_str_env new_abs_env body `thenSa` \ new_body -> + returnSa (Let (NonRec new_binder new_rhs) new_body) + +saExpr dmd str_env abs_env (Let (Rec pairs) body) + = let + (binders,rhss) = unzip pairs + str_vals = fixpoint StrAnal binders rhss str_env + abs_vals = fixpoint AbsAnal binders rhss abs_env + -- fixpoint returns widened values + new_str_env = growAbsValEnvList str_env (binders `zip` str_vals) + new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals) + in + saExpr dmd new_str_env new_abs_env body `thenSa` \ new_body -> + mapSa (saExpr minDemand new_str_env new_abs_env) rhss `thenSa` \ new_rhss -> + let +-- DON'T add demand info in a Rec! +-- a) it's useless: we can't do let-to-case +-- b) it's incorrect. Consider +-- letrec x = ...y... +-- y = ...x... +-- in ...x... +-- When we ask whether y is demanded we'll bind y to bottom and +-- evaluate the body of the letrec. But that will result in our +-- deciding that y is absent, which is plain wrong! +-- It's much easier simply not to do this. + + improved_binders = zipWith3Equal "saExpr" addStrictnessInfoToId + str_vals abs_vals binders + + new_pairs = improved_binders `zip` new_rhss + in + returnSa (Let (Rec new_pairs) new_body) +\end{code} + + +%************************************************************************ +%* * +\subsection[computeInfos]{Add computed info to binders} +%* * +%************************************************************************ + +Important note (Sept 93). @addStrictnessInfoToId@ is used only for +let(rec) bound variables, and is use to attach the strictness (not +demand) info to the binder. We are careful to restrict this +strictness info to the lambda-bound arguments which are actually +visible, at the top level, lest we accidentally lose laziness by +eagerly looking for an "extra" argument. So we "dig for lambdas" in a +rather syntactic way. + +A better idea might be to have some kind of arity analysis to +tell how many args could safely be grabbed. + +\begin{code} +addStrictnessInfoToId + :: AbsVal -- Abstract strictness value + -> AbsVal -- Ditto absence + -> Id -- The id + -> Id -- Augmented with strictness + +addStrictnessInfoToId str_val abs_val binder + = binder `setIdStrictness` findStrictness binder str_val abs_val +\end{code} + +\begin{code} +addDemandInfoToId :: Demand -> StrictEnv -> AbsenceEnv + -> CoreExpr -- The scope of the id + -> Id + -> Id -- Id augmented with Demand info + +addDemandInfoToId dmd str_env abs_env expr binder + = binder `setIdDemandInfo` (findDemand dmd str_env abs_env expr binder) + +addDemandInfoToCaseBndr dmd str_env abs_env alts binder + = binder `setIdDemandInfo` (findDemandAlts dmd str_env abs_env alts binder) +\end{code} + +%************************************************************************ +%* * +\subsection{Monad used herein for stats} +%* * +%************************************************************************ + +\begin{code} +data SaStats + = SaStats FastInt FastInt -- total/marked-demanded lambda-bound + FastInt FastInt -- total/marked-demanded case-bound + FastInt FastInt -- total/marked-demanded let-bound + -- (excl. top-level; excl. letrecs) + +nullSaStats = SaStats (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) + +thenSa :: SaM a -> (a -> SaM b) -> SaM b +thenSa_ :: SaM a -> SaM b -> SaM b +returnSa :: a -> SaM a + +{-# INLINE thenSa #-} +{-# INLINE thenSa_ #-} +{-# INLINE returnSa #-} + +tickLambda :: Id -> SaM () +tickCases :: [CoreBndr] -> SaM () +tickLet :: Id -> SaM () + +#ifndef OMIT_STRANAL_STATS +type SaM a = SaStats -> (a, SaStats) + +thenSa expr cont stats + = case (expr stats) of { (result, stats1) -> + cont result stats1 } + +thenSa_ expr cont stats + = case (expr stats) of { (_, stats1) -> + cont stats1 } + +returnSa x stats = (x, stats) + +tickLambda var (SaStats tlam dlam tc dc tlet dlet) + = case (tick_demanded var (0,0)) of { (totB, demandedB) -> + let tot = iUnbox totB ; demanded = iUnbox demandedB + in + ((), SaStats (tlam +# tot) (dlam +# demanded) tc dc tlet dlet) } + +tickCases vars (SaStats tlam dlam tc dc tlet dlet) + = case (foldr tick_demanded (0,0) vars) of { (totB, demandedB) -> + let tot = iUnbox totB ; demanded = iUnbox demandedB + in + ((), SaStats tlam dlam (tc +# tot) (dc +# demanded) tlet dlet) } + +tickLet var (SaStats tlam dlam tc dc tlet dlet) + = case (tick_demanded var (0,0)) of { (totB, demandedB) -> + let tot = iUnbox totB ; demanded = iUnbox demandedB + in + ((), SaStats tlam dlam tc dc (tlet +# tot) (dlet +# demanded)) } + +tick_demanded var (tot, demanded) + | isTyVar var = (tot, demanded) + | otherwise + = (tot + 1, + if (isStrict (idDemandInfo var)) + then demanded + 1 + else demanded) + +pp_stats (SaStats tlam dlam tc dc tlet dlet) + = hcat [ptext SLIT("Lambda vars: "), int (iBox dlam), char '/', int (iBox tlam), + ptext SLIT("; Case vars: "), int (iBox dc), char '/', int (iBox tc), + ptext SLIT("; Let vars: "), int (iBox dlet), char '/', int (iBox tlet) + ] + +#else /* OMIT_STRANAL_STATS */ +-- identity monad +type SaM a = a + +thenSa expr cont = cont expr + +thenSa_ expr cont = cont + +returnSa x = x + +tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda" +tickCases vars = panic "OMIT_STRANAL_STATS: tickCases" +tickLet var = panic "OMIT_STRANAL_STATS: tickLet" + +#endif /* OMIT_STRANAL_STATS */ + +mapSa :: (a -> SaM b) -> [a] -> SaM [b] + +mapSa f [] = returnSa [] +mapSa f (x:xs) = f x `thenSa` \ r -> + mapSa f xs `thenSa` \ rs -> + returnSa (r:rs) + +sequenceSa :: [SaM a] -> SaM [a] +sequenceSa [] = returnSa [] +sequenceSa (m:ms) = m `thenSa` \ r -> + sequenceSa ms `thenSa` \ rs -> + returnSa (r:rs) + +#endif /* OLD_STRICTNESS */ +\end{code} diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs new file mode 100644 index 0000000000..64eba89273 --- /dev/null +++ b/compiler/stranal/WorkWrap.lhs @@ -0,0 +1,403 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% +\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} + +\begin{code} +module WorkWrap ( wwTopBinds, mkWrapper ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreUnfold ( certainlyWillInline ) +import CoreLint ( showPass, endPass ) +import CoreUtils ( exprType, exprIsHNF ) +import Id ( Id, idType, isOneShotLambda, + setIdNewStrictness, mkWorkerId, + setIdWorkerInfo, setInlinePragma, + idInfo ) +import MkId ( lazyIdKey, lazyIdUnfolding ) +import Type ( Type ) +import IdInfo ( WorkerInfo(..), arityInfo, + newDemandInfo, newStrictnessInfo, unfoldingInfo, inlinePragInfo + ) +import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), + Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent + ) +import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM ) +import Unique ( hasKey ) +import BasicTypes ( RecFlag(..), isNonRec, Activation(..) ) +import VarEnv ( isEmptyVarEnv ) +import Maybes ( orElse ) +import DynFlags +import WwLib +import Util ( lengthIs, notNull ) +import Outputable +\end{code} + +We take Core bindings whose binders have: + +\begin{enumerate} + +\item Strictness attached (by the front-end of the strictness +analyser), and / or + +\item Constructed Product Result information attached by the CPR +analysis pass. + +\end{enumerate} + +and we return some ``plain'' bindings which have been +worker/wrapper-ified, meaning: + +\begin{enumerate} + +\item Functions have been split into workers and wrappers where +appropriate. If a function has both strictness and CPR properties +then only one worker/wrapper doing both transformations is produced; + +\item Binders' @IdInfos@ have been updated to reflect the existence of +these workers/wrappers (this is where we get STRICTNESS and CPR pragma +info for exported values). +\end{enumerate} + +\begin{code} + +wwTopBinds :: DynFlags + -> UniqSupply + -> [CoreBind] + -> IO [CoreBind] + +wwTopBinds dflags us binds + = do { + showPass dflags "Worker Wrapper binds"; + + -- Create worker/wrappers, and mark binders with their + -- "strictness info" [which encodes their worker/wrapper-ness] + let { binds' = workersAndWrappers us binds }; + + endPass dflags "Worker Wrapper binds" + Opt_D_dump_worker_wrapper binds' + } +\end{code} + + +\begin{code} +workersAndWrappers :: UniqSupply -> [CoreBind] -> [CoreBind] + +workersAndWrappers us top_binds + = initUs_ us $ + mapUs wwBind top_binds `thenUs` \ top_binds' -> + returnUs (concat top_binds') +\end{code} + +%************************************************************************ +%* * +\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@} +%* * +%************************************************************************ + +@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in +turn. Non-recursive case first, then recursive... + +\begin{code} +wwBind :: CoreBind + -> UniqSM [CoreBind] -- returns a WwBinding intermediate form; + -- the caller will convert to Expr/Binding, + -- as appropriate. + +wwBind (NonRec binder rhs) + = wwExpr rhs `thenUs` \ new_rhs -> + tryWW NonRecursive binder new_rhs `thenUs` \ new_pairs -> + returnUs [NonRec b e | (b,e) <- new_pairs] + -- Generated bindings must be non-recursive + -- because the original binding was. + +wwBind (Rec pairs) + = mapUs do_one pairs `thenUs` \ new_pairs -> + returnUs [Rec (concat new_pairs)] + where + do_one (binder, rhs) = wwExpr rhs `thenUs` \ new_rhs -> + tryWW Recursive binder new_rhs +\end{code} + +@wwExpr@ basically just walks the tree, looking for appropriate +annotations that can be used. Remember it is @wwBind@ that does the +matching by looking for strict arguments of the correct type. +@wwExpr@ is a version that just returns the ``Plain'' Tree. + +\begin{code} +wwExpr :: CoreExpr -> UniqSM CoreExpr + +wwExpr e@(Type _) = returnUs e +wwExpr e@(Lit _) = returnUs e +wwExpr e@(Note InlineMe expr) = returnUs e + -- Don't w/w inside InlineMe's + +wwExpr e@(Var v) + | v `hasKey` lazyIdKey = returnUs lazyIdUnfolding + | otherwise = returnUs e + -- Inline 'lazy' after strictness analysis + -- (but not inside InlineMe's) + +wwExpr (Lam binder expr) + = wwExpr expr `thenUs` \ new_expr -> + returnUs (Lam binder new_expr) + +wwExpr (App f a) + = wwExpr f `thenUs` \ new_f -> + wwExpr a `thenUs` \ new_a -> + returnUs (App new_f new_a) + +wwExpr (Note note expr) + = wwExpr expr `thenUs` \ new_expr -> + returnUs (Note note new_expr) + +wwExpr (Let bind expr) + = wwBind bind `thenUs` \ intermediate_bind -> + wwExpr expr `thenUs` \ new_expr -> + returnUs (mkLets intermediate_bind new_expr) + +wwExpr (Case expr binder ty alts) + = wwExpr expr `thenUs` \ new_expr -> + mapUs ww_alt alts `thenUs` \ new_alts -> + returnUs (Case new_expr binder ty new_alts) + where + ww_alt (con, binders, rhs) + = wwExpr rhs `thenUs` \ new_rhs -> + returnUs (con, binders, new_rhs) +\end{code} + +%************************************************************************ +%* * +\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair} +%* * +%************************************************************************ + +@tryWW@ just accumulates arguments, converts strictness info from the +front-end into the proper form, then calls @mkWwBodies@ to do +the business. + +We have to BE CAREFUL that we don't worker-wrapperize an Id that has +already been w-w'd! (You can end up with several liked-named Ids +bouncing around at the same time---absolute mischief.) So the +criterion we use is: if an Id already has an unfolding (for whatever +reason), then we don't w-w it. + +The only reason this is monadised is for the unique supply. + +\begin{code} +tryWW :: RecFlag + -> Id -- The fn binder + -> CoreExpr -- The bound rhs; its innards + -- are already ww'd + -> UniqSM [(Id, CoreExpr)] -- either *one* or *two* pairs; + -- if one, then no worker (only + -- the orig "wrapper" lives on); + -- if two, then a worker and a + -- wrapper. +tryWW is_rec fn_id rhs + | isNonRec is_rec && certainlyWillInline unfolding + -- No point in worker/wrappering a function that is going to be + -- INLINEd wholesale anyway. If the strictness analyser is run + -- twice, this test also prevents wrappers (which are INLINEd) + -- from being re-done. + -- + -- It's very important to refrain from w/w-ing an INLINE function + -- If we do so by mistake we transform + -- f = __inline (\x -> E) + -- into + -- f = __inline (\x -> case x of (a,b) -> fw E) + -- fw = \ab -> (__inline (\x -> E)) (a,b) + -- and the original __inline now vanishes, so E is no longer + -- inside its __inline wrapper. Death! Disaster! + = returnUs [ (new_fn_id, rhs) ] + + | is_thunk && worthSplittingThunk maybe_fn_dmd res_info + = ASSERT2( isNonRec is_rec, ppr new_fn_id ) -- The thunk must be non-recursive + splitThunk new_fn_id rhs + + | is_fun && worthSplittingFun wrap_dmds res_info + = splitFun new_fn_id fn_info wrap_dmds res_info inline_prag rhs + + | otherwise + = returnUs [ (new_fn_id, rhs) ] + + where + fn_info = idInfo fn_id + maybe_fn_dmd = newDemandInfo fn_info + unfolding = unfoldingInfo fn_info + inline_prag = inlinePragInfo fn_info + + -- In practice it always will have a strictness + -- signature, even if it's a uninformative one + strict_sig = newStrictnessInfo fn_info `orElse` topSig + StrictSig (DmdType env wrap_dmds res_info) = strict_sig + + -- new_fn_id has the DmdEnv zapped. + -- (a) it is never used again + -- (b) it wastes space + -- (c) it becomes incorrect as things are cloned, because + -- we don't push the substitution into it + new_fn_id | isEmptyVarEnv env = fn_id + | otherwise = fn_id `setIdNewStrictness` + StrictSig (mkTopDmdType wrap_dmds res_info) + + is_fun = notNull wrap_dmds + is_thunk = not is_fun && not (exprIsHNF rhs) + +--------------------- +splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs + = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) + -- The arity should match the signature + mkWwBodies fun_ty wrap_dmds res_info one_shots `thenUs` \ (work_demands, wrap_fn, work_fn) -> + getUniqueUs `thenUs` \ work_uniq -> + let + work_rhs = work_fn rhs + work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) + `setInlinePragma` inline_prag + `setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info) + -- Even though we may not be at top level, + -- it's ok to give it an empty DmdEnv + + wrap_rhs = wrap_fn work_id + wrap_id = fn_id `setIdWorkerInfo` HasWorker work_id arity + `setInlinePragma` AlwaysActive -- Zap any inline pragma; + -- Put it on the worker instead + in + returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) + -- Worker first, because wrapper mentions it + -- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it + where + fun_ty = idType fn_id + + arity = arityInfo fn_info -- The arity is set by the simplifier using exprEtaExpandArity + -- So it may be more than the number of top-level-visible lambdas + + work_res_info | isBotRes res_info = BotRes -- Cpr stuff done by wrapper + | otherwise = TopRes + + one_shots = get_one_shots rhs + +-- If the original function has one-shot arguments, it is important to +-- make the wrapper and worker have corresponding one-shot arguments too. +-- Otherwise we spuriously float stuff out of case-expression join points, +-- which is very annoying. +get_one_shots (Lam b e) + | isId b = isOneShotLambda b : get_one_shots e + | otherwise = get_one_shots e +get_one_shots (Note _ e) = get_one_shots e +get_one_shots other = noOneShotInfo +\end{code} + +Thunk splitting +~~~~~~~~~~~~~~~ +Suppose x is used strictly (never mind whether it has the CPR +property). + + let + x* = x-rhs + in body + +splitThunk transforms like this: + + let + x* = case x-rhs of { I# a -> I# a } + in body + +Now simplifier will transform to + + case x-rhs of + I# a -> let x* = I# b + in body + +which is what we want. Now suppose x-rhs is itself a case: + + x-rhs = case e of { T -> I# a; F -> I# b } + +The join point will abstract over a, rather than over (which is +what would have happened before) which is fine. + +Notice that x certainly has the CPR property now! + +In fact, splitThunk uses the function argument w/w splitting +function, so that if x's demand is deeper (say U(U(L,L),L)) +then the splitting will go deeper too. + +\begin{code} +-- splitThunk converts the *non-recursive* binding +-- x = e +-- into +-- x = let x = e +-- in case x of +-- I# y -> let x = I# y in x } +-- See comments above. Is it not beautifully short? + +splitThunk fn_id rhs + = mkWWstr [fn_id] `thenUs` \ (_, wrap_fn, work_fn) -> + returnUs [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ] +\end{code} + + +%************************************************************************ +%* * +\subsection{Functions over Demands} +%* * +%************************************************************************ + +\begin{code} +worthSplittingFun :: [Demand] -> DmdResult -> Bool + -- True <=> the wrapper would not be an identity function +worthSplittingFun ds res + = any worth_it ds || returnsCPR res + -- worthSplitting returns False for an empty list of demands, + -- and hence do_strict_ww is False if arity is zero and there is no CPR + + -- We used not to split if the result is bottom. + -- [Justification: there's no efficiency to be gained.] + -- But it's sometimes bad not to make a wrapper. Consider + -- fw = \x# -> let x = I# x# in case e of + -- p1 -> error_fn x + -- p2 -> error_fn x + -- p3 -> the real stuff + -- The re-boxing code won't go away unless error_fn gets a wrapper too. + -- [We don't do reboxing now, but in general it's better to pass + -- an unboxed thing to f, and have it reboxed in the error cases....] + where + worth_it Abs = True -- Absent arg + worth_it (Eval (Prod ds)) = True -- Product arg to evaluate + worth_it other = False + +worthSplittingThunk :: Maybe Demand -- Demand on the thunk + -> DmdResult -- CPR info for the thunk + -> Bool +worthSplittingThunk maybe_dmd res + = worth_it maybe_dmd || returnsCPR res + where + -- Split if the thing is unpacked + worth_it (Just (Eval (Prod ds))) = not (all isAbsent ds) + worth_it other = False +\end{code} + + + +%************************************************************************ +%* * +\subsection{The worker wrapper core} +%* * +%************************************************************************ + +@mkWrapper@ is called when importing a function. We have the type of +the function and the name of its worker, and we want to make its body (the wrapper). + +\begin{code} +mkWrapper :: Type -- Wrapper type + -> StrictSig -- Wrapper strictness info + -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id + +mkWrapper fun_ty (StrictSig (DmdType _ demands res_info)) + = mkWwBodies fun_ty demands res_info noOneShotInfo `thenUs` \ (_, wrap_fn, _) -> + returnUs wrap_fn + +noOneShotInfo = repeat False +\end{code} diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs new file mode 100644 index 0000000000..e44e521c83 --- /dev/null +++ b/compiler/stranal/WwLib.lhs @@ -0,0 +1,514 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% +\section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser} + +\begin{code} +module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreUtils ( exprType ) +import Id ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo, + isOneShotLambda, setOneShotLambda, setIdUnfolding, + setIdInfo + ) +import IdInfo ( vanillaIdInfo ) +import DataCon ( splitProductType_maybe, splitProductType ) +import NewDemand ( Demand(..), DmdResult(..), Demands(..) ) +import MkId ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID ) +import TysWiredIn ( tupleCon ) +import Type ( Type, isUnLiftedType, mkFunTys, + splitForAllTys, splitFunTys, splitRecNewType_maybe, isAlgType + ) +import BasicTypes ( Boxity(..) ) +import Var ( Var, isId ) +import UniqSupply ( returnUs, thenUs, getUniquesUs, UniqSM ) +import Util ( zipWithEqual, notNull ) +import Outputable +import List ( zipWith4 ) +\end{code} + + +%************************************************************************ +%* * +\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@} +%* * +%************************************************************************ + +Here's an example. The original function is: + +\begin{verbatim} +g :: forall a . Int -> [a] -> a + +g = /\ a -> \ x ys -> + case x of + 0 -> head ys + _ -> head (tail ys) +\end{verbatim} + +From this, we want to produce: +\begin{verbatim} +-- wrapper (an unfolding) +g :: forall a . Int -> [a] -> a + +g = /\ a -> \ x ys -> + case x of + I# x# -> $wg a x# ys + -- call the worker; don't forget the type args! + +-- worker +$wg :: forall a . Int# -> [a] -> a + +$wg = /\ a -> \ x# ys -> + let + x = I# x# + in + case x of -- note: body of g moved intact + 0 -> head ys + _ -> head (tail ys) +\end{verbatim} + +Something we have to be careful about: Here's an example: + +\begin{verbatim} +-- "f" strictness: U(P)U(P) +f (I# a) (I# b) = a +# b + +g = f -- "g" strictness same as "f" +\end{verbatim} + +\tr{f} will get a worker all nice and friendly-like; that's good. +{\em But we don't want a worker for \tr{g}}, even though it has the +same strictness as \tr{f}. Doing so could break laziness, at best. + +Consequently, we insist that the number of strictness-info items is +exactly the same as the number of lambda-bound arguments. (This is +probably slightly paranoid, but OK in practice.) If it isn't the +same, we ``revise'' the strictness info, so that we won't propagate +the unusable strictness-info into the interfaces. + + +%************************************************************************ +%* * +\subsection{The worker wrapper core} +%* * +%************************************************************************ + +@mkWwBodies@ is called when doing the worker/wrapper split inside a module. + +\begin{code} +mkWwBodies :: Type -- Type of original function + -> [Demand] -- Strictness of original function + -> DmdResult -- Info about function result + -> [Bool] -- One-shot-ness of the function + -> UniqSM ([Demand], -- Demands for worker (value) args + Id -> CoreExpr, -- Wrapper body, lacking only the worker Id + CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs + +-- wrap_fn_args E = \x y -> E +-- work_fn_args E = E x y + +-- wrap_fn_str E = case x of { (a,b) -> +-- case a of { (a1,a2) -> +-- E a1 a2 b y }} +-- work_fn_str E = \a2 a2 b y -> +-- let a = (a1,a2) in +-- let x = (a,b) in +-- E + +mkWwBodies fun_ty demands res_info one_shots + = mkWWargs fun_ty demands one_shots' `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) -> + mkWWstr wrap_args `thenUs` \ (work_args, wrap_fn_str, work_fn_str) -> + let + (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty + in + -- Don't do CPR if the worker doesn't have any value arguments + -- Then the worker is just a constant, so we don't want to unbox it. + (if any isId work_args then + mkWWcpr res_ty res_info + else + returnUs (id, id, res_ty) + ) `thenUs` \ (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) -> + + returnUs ([idNewDemandInfo v | v <- work_args, isId v], + Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var, + mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) + -- We use an INLINE unconditionally, even if the wrapper turns out to be + -- something trivial like + -- fw = ... + -- f = __inline__ (coerce T fw) + -- The point is to propagate the coerce to f's call sites, so even though + -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent + -- fw from being inlined into f's RHS + where + one_shots' = one_shots ++ repeat False +\end{code} + + +%************************************************************************ +%* * +\subsection{Making wrapper args} +%* * +%************************************************************************ + +During worker-wrapper stuff we may end up with an unlifted thing +which we want to let-bind without losing laziness. So we +add a void argument. E.g. + + f = /\a -> \x y z -> E::Int# -- E does not mention x,y,z +==> + fw = /\ a -> \void -> E + f = /\ a -> \x y z -> fw realworld + +We use the state-token type which generates no code. + +\begin{code} +mkWorkerArgs :: [Var] + -> Type -- Type of body + -> ([Var], -- Lambda bound args + [Var]) -- Args at call site +mkWorkerArgs args res_ty + | any isId args || not (isUnLiftedType res_ty) + = (args, args) + | otherwise + = (args ++ [voidArgId], args ++ [realWorldPrimId]) +\end{code} + + +%************************************************************************ +%* * +\subsection{Coercion stuff} +%* * +%************************************************************************ + + +We really want to "look through" coerces. +Reason: I've seen this situation: + + let f = coerce T (\s -> E) + in \x -> case x of + p -> coerce T' f + q -> \s -> E2 + r -> coerce T' f + +If only we w/w'd f, we'd get + let f = coerce T (\s -> fw s) + fw = \s -> E + in ... + +Now we'll inline f to get + + let fw = \s -> E + in \x -> case x of + p -> fw + q -> \s -> E2 + r -> fw + +Now we'll see that fw has arity 1, and will arity expand +the \x to get what we want. + +\begin{code} +-- mkWWargs is driven off the function type and arity. +-- It chomps bites off foralls, arrows, newtypes +-- and keeps repeating that until it's satisfied the supplied arity + +mkWWargs :: Type + -> [Demand] + -> [Bool] -- True for a one-shot arg; ** may be infinite ** + -> UniqSM ([Var], -- Wrapper args + CoreExpr -> CoreExpr, -- Wrapper fn + CoreExpr -> CoreExpr, -- Worker fn + Type) -- Type of wrapper body + +mkWWargs fun_ty demands one_shots + | Just rep_ty <- splitRecNewType_maybe fun_ty + -- The newtype case is for when the function has + -- a recursive newtype after the arrow (rare) + -- We check for arity >= 0 to avoid looping in the case + -- of a function whose type is, in effect, infinite + -- [Arity is driven by looking at the term, not just the type.] + -- + -- It's also important when we have a function returning (say) a pair + -- wrapped in a recursive newtype, at least if CPR analysis can look + -- through such newtypes, which it probably can since they are + -- simply coerces. + = mkWWargs rep_ty demands one_shots `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) -> + returnUs (wrap_args, + Note (Coerce fun_ty rep_ty) . wrap_fn_args, + work_fn_args . Note (Coerce rep_ty fun_ty), + res_ty) + + | notNull demands + = getUniquesUs `thenUs` \ wrap_uniqs -> + let + (tyvars, tau) = splitForAllTys fun_ty + (arg_tys, body_ty) = splitFunTys tau + + n_demands = length demands + n_arg_tys = length arg_tys + n_args = n_demands `min` n_arg_tys + + new_fun_ty = mkFunTys (drop n_demands arg_tys) body_ty + new_demands = drop n_arg_tys demands + new_one_shots = drop n_args one_shots + + val_args = zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots + wrap_args = tyvars ++ val_args + in +{- ASSERT( notNull tyvars || notNull arg_tys ) -} + if (null tyvars) && (null arg_tys) then + pprTrace "mkWWargs" (ppr fun_ty $$ ppr demands) + returnUs ([], id, id, fun_ty) + else + + mkWWargs new_fun_ty + new_demands + new_one_shots `thenUs` \ (more_wrap_args, wrap_fn_args, work_fn_args, res_ty) -> + + returnUs (wrap_args ++ more_wrap_args, + mkLams wrap_args . wrap_fn_args, + work_fn_args . applyToVars wrap_args, + res_ty) + + | otherwise + = returnUs ([], id, id, fun_ty) + + +applyToVars :: [Var] -> CoreExpr -> CoreExpr +applyToVars vars fn = mkVarApps fn vars + +mk_wrap_arg uniq ty dmd one_shot + = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal FSLIT("w") uniq ty) dmd) + where + set_one_shot True id = setOneShotLambda id + set_one_shot False id = id +\end{code} + + +%************************************************************************ +%* * +\subsection{Strictness stuff} +%* * +%************************************************************************ + +\begin{code} +mkWWstr :: [Var] -- Wrapper args; have their demand info on them + -- *Includes type variables* + -> UniqSM ([Var], -- Worker args + CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call + -- and without its lambdas + -- This fn adds the unboxing + + CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function, + -- and lacking its lambdas. + -- This fn does the reboxing + +---------------------- +nop_fn body = body + +---------------------- +mkWWstr [] + = returnUs ([], nop_fn, nop_fn) + +mkWWstr (arg : args) + = mkWWstr_one arg `thenUs` \ (args1, wrap_fn1, work_fn1) -> + mkWWstr args `thenUs` \ (args2, wrap_fn2, work_fn2) -> + returnUs (args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2) + + +---------------------- +-- mkWWstr_one wrap_arg = (work_args, wrap_fn, work_fn) +-- * wrap_fn assumes wrap_arg is in scope, +-- brings into scope work_args (via cases) +-- * work_fn assumes work_args are in scope, a +-- brings into scope wrap_arg (via lets) + +mkWWstr_one arg + | isTyVar arg + = returnUs ([arg], nop_fn, nop_fn) + + | otherwise + = case idNewDemandInfo arg of + + -- Absent case. We don't deal with absence for unlifted types, + -- though, because it's not so easy to manufacture a placeholder + -- We'll see if this turns out to be a problem + Abs | not (isUnLiftedType (idType arg)) -> + returnUs ([], nop_fn, mk_absent_let arg) + + -- Unpack case + Eval (Prod cs) + | Just (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) + <- splitProductType_maybe (idType arg) + -> getUniquesUs `thenUs` \ uniqs -> + let + unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys + unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs + unbox_fn = mk_unpk_case arg unpk_args data_con arg_tycon + rebox_fn = Let (NonRec arg con_app) + con_app = mkConApp data_con (map Type tycon_arg_tys ++ map Var unpk_args) + in + mkWWstr unpk_args_w_ds `thenUs` \ (worker_args, wrap_fn, work_fn) -> + returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) + -- Don't pass the arg, rebox instead + + -- `seq` demand; evaluate in wrapper in the hope + -- of dropping seqs in the worker + Eval (Poly Abs) + -> let + arg_w_unf = arg `setIdUnfolding` evaldUnfolding + -- Tell the worker arg that it's sure to be evaluated + -- so that internal seqs can be dropped + in + returnUs ([arg_w_unf], mk_seq_case arg, nop_fn) + -- Pass the arg, anyway, even if it is in theory discarded + -- Consider + -- f x y = x `seq` y + -- x gets a (Eval (Poly Abs)) demand, but if we fail to pass it to the worker + -- we ABSOLUTELY MUST record that x is evaluated in the wrapper. + -- Something like: + -- f x y = x `seq` fw y + -- fw y = let x{Evald} = error "oops" in (x `seq` y) + -- If we don't pin on the "Evald" flag, the seq doesn't disappear, and + -- we end up evaluating the absent thunk. + -- But the Evald flag is pretty weird, and I worry that it might disappear + -- during simplification, so for now I've just nuked this whole case + + -- Other cases + other_demand -> returnUs ([arg], nop_fn, nop_fn) + + where + -- If the wrapper argument is a one-shot lambda, then + -- so should (all) the corresponding worker arguments be + -- This bites when we do w/w on a case join point + set_worker_arg_info worker_arg demand = set_one_shot (setIdNewDemandInfo worker_arg demand) + + set_one_shot | isOneShotLambda arg = setOneShotLambda + | otherwise = \x -> x +\end{code} + + +%************************************************************************ +%* * +\subsection{CPR stuff} +%* * +%************************************************************************ + + +@mkWWcpr@ takes the worker/wrapper pair produced from the strictness +info and adds in the CPR transformation. The worker returns an +unboxed tuple containing non-CPR components. The wrapper takes this +tuple and re-produces the correct structured output. + +The non-CPR results appear ordered in the unboxed tuple as if by a +left-to-right traversal of the result structure. + + +\begin{code} +mkWWcpr :: Type -- function body type + -> DmdResult -- CPR analysis results + -> UniqSM (CoreExpr -> CoreExpr, -- New wrapper + CoreExpr -> CoreExpr, -- New worker + Type) -- Type of worker's body + +mkWWcpr body_ty RetCPR + | not (isAlgType body_ty) + = WARN( True, text "mkWWcpr: non-algebraic body type" <+> ppr body_ty ) + returnUs (id, id, body_ty) + + | n_con_args == 1 && isUnLiftedType con_arg_ty1 + -- Special case when there is a single result of unlifted type + -- + -- Wrapper: case (..call worker..) of x -> C x + -- Worker: case ( ..body.. ) of C x -> x + = getUniquesUs `thenUs` \ (work_uniq : arg_uniq : _) -> + let + work_wild = mk_ww_local work_uniq body_ty + arg = mk_ww_local arg_uniq con_arg_ty1 + con_app = mkConApp data_con (map Type tycon_arg_tys ++ [Var arg]) + in + returnUs (\ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)], + \ body -> workerCase body work_wild con_arg_ty1 [(DataAlt data_con, [arg], Var arg)], + con_arg_ty1) + + | otherwise -- The general case + -- Wrapper: case (..call worker..) of (# a, b #) -> C a b + -- Worker: case ( ...body... ) of C a b -> (# a, b #) + = getUniquesUs `thenUs` \ uniqs -> + let + (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys) + arg_vars = map Var args + ubx_tup_con = tupleCon Unboxed n_con_args + ubx_tup_ty = exprType ubx_tup_app + ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars) + con_app = mkConApp data_con (map Type tycon_arg_tys ++ arg_vars) + in + returnUs (\ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)], + \ body -> workerCase body work_wild ubx_tup_ty [(DataAlt data_con, args, ubx_tup_app)], + ubx_tup_ty) + where + (_, tycon_arg_tys, data_con, con_arg_tys) = splitProductType "mkWWcpr" body_ty + n_con_args = length con_arg_tys + con_arg_ty1 = head con_arg_tys + +mkWWcpr body_ty other -- No CPR info + = returnUs (id, id, body_ty) + +-- If the original function looked like +-- f = \ x -> _scc_ "foo" E +-- +-- then we want the CPR'd worker to look like +-- \ x -> _scc_ "foo" (case E of I# x -> x) +-- and definitely not +-- \ x -> case (_scc_ "foo" E) of I# x -> x) +-- +-- This transform doesn't move work or allocation +-- from one cost centre to another + +workerCase (Note (SCC cc) e) arg ty alts = Note (SCC cc) (Case e arg ty alts) +workerCase e arg ty alts = Case e arg ty alts +\end{code} + + +%************************************************************************ +%* * +\subsection{Utilities} +%* * +%************************************************************************ + + +\begin{code} +mk_absent_let arg body + | not (isUnLiftedType arg_ty) + = Let (NonRec arg abs_rhs) body + | otherwise + = panic "WwLib: haven't done mk_absent_let for primitives yet" + where + arg_ty = idType arg + abs_rhs = mkRuntimeErrorApp rUNTIME_ERROR_ID arg_ty msg + msg = "Oops! Entered absent arg " ++ showSDocDebug (ppr arg <+> ppr (idType arg)) + +mk_unpk_case arg unpk_args boxing_con boxing_tycon body + -- A data type + = Case (Var arg) + (sanitiseCaseBndr arg) + (exprType body) + [(DataAlt boxing_con, unpk_args, body)] + +mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)] + +sanitiseCaseBndr :: Id -> Id +-- The argument we are scrutinising has the right type to be +-- a case binder, so it's convenient to re-use it for that purpose. +-- But we *must* throw away all its IdInfo. In particular, the argument +-- will have demand info on it, and that demand info may be incorrect for +-- the case binder. e.g. case ww_arg of ww_arg { I# x -> ... } +-- Quite likely ww_arg isn't used in '...'. The case may get discarded +-- if the case binder says "I'm demanded". This happened in a situation +-- like (x+y) `seq` .... +sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo + +mk_ww_local uniq ty = mkSysLocal FSLIT("ww") uniq ty +\end{code} |