X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecConstr.lhs;h=6cc05a3dc652d6289ad68ac14e314959a7a6e6f3;hp=bd70e284ed34bedae07d05865125762697add821;hb=c0687066474aa4ce4912f31a5c09c1bcd673fb06;hpb=1e50fd4185479a62e02d987bdfcb1c62712859ca diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index bd70e28..6cc05a3 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -1,3 +1,8 @@ +ToDo [Nov 2010] +~~~~~~~~~~~~~~~ +1. Use a library type rather than an annotation for ForceSpecConstr +2. Nuke NoSpecConstr + % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % @@ -11,7 +16,10 @@ -- for details module SpecConstr( - specConstrProgram + specConstrProgram +#ifdef GHCI + , SpecConstrAnnotation(..) +#endif ) where #include "HsVersions.h" @@ -21,23 +29,28 @@ import CoreSubst import CoreUtils import CoreUnfold ( couldBeSmallEnoughToInline ) import CoreFVs ( exprsFreeVars ) +import CoreMonad +import HscTypes ( ModGuts(..) ) import WwLib ( mkWorkerArgs ) -import DataCon ( dataConRepArity, dataConUnivTyVars ) -import Coercion +import DataCon +import Coercion hiding( substTy, substCo ) import Rules -import Type hiding( substTy ) +import Type hiding ( substTy ) import Id -import MkId ( mkImpossibleExpr ) +import MkCore ( mkImpossibleExpr ) import Var import VarEnv import VarSet import Name +import BasicTypes import DynFlags ( DynFlags(..) ) import StaticFlags ( opt_PprStyle_Debug ) -import StaticFlags ( opt_SpecInlineJoinPoints ) -import BasicTypes ( Activation(..) ) import Maybes ( orElse, catMaybes, isJust, isNothing ) +import Demand +import DmdAnal ( both ) +import Serialized ( deserializeWithData ) import Util +import Pair import UniqSupply import Outputable import FastString @@ -45,6 +58,15 @@ import UniqFM import MonadUtils import Control.Monad ( zipWithM ) import Data.List + + +-- See Note [SpecConstrAnnotation] +#ifndef GHCI +type SpecConstrAnnotation = () +#else +import TyCon ( TyCon ) +import GHC.Exts( SpecConstrAnnotation(..) ) +#endif \end{code} ----------------------------------------------------- @@ -365,6 +387,18 @@ specialising the loops arising from stream fusion, for example in NDP where we were getting literally hundreds of (mostly unused) specialisations of a local function. +In a case like the above we end up never calling the original un-specialised +function. (Although we still leave its code around just in case.) + +However, if we find any boring calls in the body, including *unsaturated* +ones, such as + letrec foo x y = ....foo... + in map foo xs +then we will end up calling the un-specialised function, so then we *should* +use the calls in the un-specialised RHS as seeds. We call these "boring +call patterns, and callsToPats reports if it finds any of these. + + Note [Do not specialise diverging functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Specialising a function that just diverges is a waste of code. @@ -378,6 +412,114 @@ But fspec doesn't have decent strictnes info. As it happened, and hence f. But now f's strictness is less than its arity, which breaks an invariant. +Note [SpecConstrAnnotation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SpecConstrAnnotation is defined in GHC.Exts, and is only guaranteed to +be available in stage 2 (well, until the bootstrap compiler can be +guaranteed to have it) + +So we define it to be () in stage1 (ie when GHCI is undefined), and +'#ifdef' out the code that uses it. + +See also Note [Forcing specialisation] + +Note [Forcing specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With stream fusion and in other similar cases, we want to fully specialise +some (but not necessarily all!) loops regardless of their size and the +number of specialisations. We allow a library to specify this by annotating +a type with ForceSpecConstr and then adding a parameter of that type to the +loop. Here is a (simplified) example from the vector library: + + data SPEC = SPEC | SPEC2 + {-# ANN type SPEC ForceSpecConstr #-} + + foldl :: (a -> b -> a) -> a -> Stream b -> a + {-# INLINE foldl #-} + foldl f z (Stream step s _) = foldl_loop SPEC z s + where + foldl_loop !sPEC z s = case step s of + Yield x s' -> foldl_loop sPEC (f z x) s' + Skip -> foldl_loop sPEC z s' + Done -> z + +SpecConstr will spot the SPEC parameter and always fully specialise +foldl_loop. Note that + + * We have to prevent the SPEC argument from being removed by + w/w which is why (a) SPEC is a sum type, and (b) we have to seq on + the SPEC argument. + + * And lastly, the SPEC argument is ultimately eliminated by + SpecConstr itself so there is no runtime overhead. + +This is all quite ugly; we ought to come up with a better design. + +ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set +sc_force to True when calling specLoop. This flag does three things: + * Ignore specConstrThreshold, to specialise functions of arbitrary size + (see scTopBind) + * Ignore specConstrCount, to make arbitrary numbers of specialisations + (see specialise) + * Specialise even for arguments that are not scrutinised in the loop + (see argToPat; Trac #4488) + +This flag is inherited for nested non-recursive bindings (which are likely to +be join points and hence should be fully specialised) but reset for nested +recursive bindings. + +What alternatives did I consider? Annotating the loop itself doesn't +work because (a) it is local and (b) it will be w/w'ed and I having +w/w propagating annotation somehow doesn't seem like a good idea. The +types of the loop arguments really seem to be the most persistent +thing. + +Annotating the types that make up the loop state doesn't work, +either, because (a) it would prevent us from using types like Either +or tuples here, (b) we don't want to restrict the set of types that +can be used in Stream states and (c) some types are fixed by the user +(e.g., the accumulator here) but we still want to specialise as much +as possible. + +ForceSpecConstr is done by way of an annotation: + data SPEC = SPEC | SPEC2 + {-# ANN type SPEC ForceSpecConstr #-} +But SPEC is the *only* type so annotated, so it'd be better to +use a particular library type. + +Alternatives to ForceSpecConstr +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instead of giving the loop an extra argument of type SPEC, we +also considered *wrapping* arguments in SPEC, thus + data SPEC a = SPEC a | SPEC2 + + loop = \arg -> case arg of + SPEC state -> + case state of (x,y) -> ... loop (SPEC (x',y')) ... + S2 -> error ... +The idea is that a SPEC argument says "specialise this argument +regardless of whether the function case-analyses it. But this +doesn't work well: + * SPEC must still be a sum type, else the strictness analyser + eliminates it + * But that means that 'loop' won't be strict in its real payload +This loss of strictness in turn screws up specialisation, because +we may end up with calls like + loop (SPEC (case z of (p,q) -> (q,p))) +Without the SPEC, if 'loop' was strict, the case would move out +and we'd see loop applied to a pair. But if 'loop' isn' strict +this doesn't look like a specialisable call. + +Note [NoSpecConstr] +~~~~~~~~~~~~~~~~~~~ +The ignoreDataCon stuff allows you to say + {-# ANN type T NoSpecConstr #-} +to mean "don't specialise on arguments of this type. It was added +before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised +regardless of size; and then we needed a way to turn that *off*. Now +that we have ForceSpecConstr, this NoSpecConstr is probably redundant. +(Used only for PArray.) + ----------------------------------------------------- Stuff not yet handled ----------------------------------------------------- @@ -453,8 +595,6 @@ But perhaps the first one isn't good. After all, we know that tpl_B2 is a T (I# x) really, because T is strict and Int has one constructor. (We can't unbox the strict fields, becuase T is polymorphic!) - - %************************************************************************ %* * \subsection{Top level wrapper stuff} @@ -462,8 +602,14 @@ unbox the strict fields, becuase T is polymorphic!) %************************************************************************ \begin{code} -specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind] -specConstrProgram dflags us binds = fst $ initUs us (go (initScEnv dflags) binds) +specConstrProgram :: ModGuts -> CoreM ModGuts +specConstrProgram guts + = do + dflags <- getDynFlags + us <- getUniqueSupplyM + annos <- getFirstAnnotations deserializeWithData guts + let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts)) + return (guts { mg_binds = binds' }) where go _ [] = return [] go env (bind:binds) = do (env', bind') <- scTopBind env bind @@ -481,6 +627,9 @@ specConstrProgram dflags us binds = fst $ initUs us (go (initScEnv dflags) binds \begin{code} data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold sc_count :: Maybe Int, -- Max # of specialisations for any one fn + -- See Note [Avoiding exponential blowup] + sc_force :: Bool, -- Force specialisation? + -- See Note [Forcing specialisation] sc_subst :: Subst, -- Current substitution -- Maps InIds to OutExprs @@ -489,14 +638,17 @@ data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold -- Binds interesting non-top-level variables -- Domain is OutVars (*after* applying the substitution) - sc_vals :: ValueEnv + sc_vals :: ValueEnv, -- Domain is OutIds (*after* applying the substitution) -- Used even for top-level bindings (but not imported ones) + + sc_annotations :: UniqFM SpecConstrAnnotation } --------------------- -- As we go, we apply a substitution (sc_subst) to the current term type InExpr = CoreExpr -- _Before_ applying the subst +type InVar = Var type OutExpr = CoreExpr -- _After_ applying the subst type OutId = Id @@ -508,6 +660,7 @@ type HowBoundEnv = VarEnv HowBound -- Domain is OutVars --------------------- type ValueEnv = IdEnv Value -- Domain is OutIds data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors + -- The AltCon is never DEFAULT | LambdaVal -- Inlinable lambdas or PAPs instance Outputable Value where @@ -515,13 +668,15 @@ instance Outputable Value where ppr LambdaVal = ptext (sLit "") --------------------- -initScEnv :: DynFlags -> ScEnv -initScEnv dflags +initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv +initScEnv dflags anns = SCE { sc_size = specConstrThreshold dflags, sc_count = specConstrCount dflags, + sc_force = False, sc_subst = emptySubst, sc_how_bound = emptyVarEnv, - sc_vals = emptyVarEnv } + sc_vals = emptyVarEnv, + sc_annotations = anns } data HowBound = RecFun -- These are the recursive functions for which -- we seek interesting call patterns @@ -533,15 +688,21 @@ instance Outputable HowBound where ppr RecFun = text "RecFun" ppr RecArg = text "RecArg" +scForce :: ScEnv -> Bool -> ScEnv +scForce env b = env { sc_force = b } + lookupHowBound :: ScEnv -> Id -> Maybe HowBound lookupHowBound env id = lookupVarEnv (sc_how_bound env) id scSubstId :: ScEnv -> Id -> CoreExpr -scSubstId env v = lookupIdSubst (sc_subst env) v +scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v scSubstTy :: ScEnv -> Type -> Type scSubstTy env ty = substTy (sc_subst env) ty +scSubstCo :: ScEnv -> Coercion -> Coercion +scSubstCo env co = substCo (sc_subst env) co + zapScSubst :: ScEnv -> ScEnv zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) } @@ -590,7 +751,7 @@ extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv extendValEnv env _ Nothing = env extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv } -extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var]) +extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var]) -- When we encounter -- case scrut of b -- C x y -> ... @@ -598,21 +759,20 @@ extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var]) -- NB1: Extends only the sc_vals part of the envt -- NB2: Kill the dead-ness info on the pattern binders x,y, since -- they are potentially made alive by the [b -> C x y] binding -extendCaseBndrs env case_bndr con alt_bndrs - | isDeadBinder case_bndr - = (env, alt_bndrs) - | otherwise - = (env1, map zap alt_bndrs) - -- NB: We used to bind v too, if scrut = (Var v); but - -- the simplifer has already done this so it seems - -- redundant to do so here - -- case scrut of - -- Var v -> extendValEnv env1 v cval - -- _other -> env1 +extendCaseBndrs env scrut case_bndr con alt_bndrs + = (env2, alt_bndrs') where - zap v | isTyVar v = v -- See NB2 above - | otherwise = zapIdOccInfo v - env1 = extendValEnv env case_bndr cval + live_case_bndr = not (isDeadBinder case_bndr) + env1 | Var v <- scrut = extendValEnv env v cval + | otherwise = env -- See Note [Add scrutinee to ValueEnv too] + env2 | live_case_bndr = extendValEnv env1 case_bndr cval + | otherwise = env1 + + alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr } + = map zap alt_bndrs + | otherwise + = alt_bndrs + cval = case con of DEFAULT -> Nothing LitAlt {} -> Just (ConVal con []) @@ -620,8 +780,103 @@ extendCaseBndrs env case_bndr con alt_bndrs where vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ varsToCoreExprs alt_bndrs + + zap v | isTyVar v = v -- See NB2 above + | otherwise = zapIdOccInfo v + + +decreaseSpecCount :: ScEnv -> Int -> ScEnv +-- See Note [Avoiding exponential blowup] +decreaseSpecCount env n_specs + = env { sc_count = case sc_count env of + Nothing -> Nothing + Just n -> Just (n `div` (n_specs + 1)) } + -- The "+1" takes account of the original function; + -- See Note [Avoiding exponential blowup] + +--------------------------------------------------- +-- See Note [SpecConstrAnnotation] +ignoreType :: ScEnv -> Type -> Bool +ignoreDataCon :: ScEnv -> DataCon -> Bool +forceSpecBndr :: ScEnv -> Var -> Bool +#ifndef GHCI +ignoreType _ _ = False +ignoreDataCon _ _ = False +forceSpecBndr _ _ = False + +#else /* GHCI */ + +ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc) + +ignoreType env ty + = case splitTyConApp_maybe ty of + Just (tycon, _) -> ignoreTyCon env tycon + _ -> False + +ignoreTyCon :: ScEnv -> TyCon -> Bool +ignoreTyCon env tycon + = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr + +forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var + +forceSpecFunTy :: ScEnv -> Type -> Bool +forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys + +forceSpecArgTy :: ScEnv -> Type -> Bool +forceSpecArgTy env ty + | Just ty' <- coreView ty = forceSpecArgTy env ty' + +forceSpecArgTy env ty + | Just (tycon, tys) <- splitTyConApp_maybe ty + , tycon /= funTyCon + = lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr + || any (forceSpecArgTy env) tys + +forceSpecArgTy _ _ = False +#endif /* GHCI */ \end{code} +Note [Add scrutinee to ValueEnv too] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + case x of y + (a,b) -> case b of c + I# v -> ...(f y)... +By the time we get to the call (f y), the ValueEnv +will have a binding for y, and for c + y -> (a,b) + c -> I# v +BUT that's not enough! Looking at the call (f y) we +see that y is pair (a,b), but we also need to know what 'b' is. +So in extendCaseBndrs we must *also* add the binding + b -> I# v +else we lose a useful specialisation for f. This is necessary even +though the simplifier has systematically replaced uses of 'x' with 'y' +and 'b' with 'c' in the code. The use of 'b' in the ValueEnv came +from outside the case. See Trac #4908 for the live example. + +Note [Avoiding exponential blowup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_count field of the ScEnv says how many times we are prepared to +duplicate a single function. But we must take care with recursive +specialiations. Consider + + let $j1 = let $j2 = let $j3 = ... + in + ...$j3... + in + ...$j2... + in + ...$j1... + +If we specialise $j1 then in each specialisation (as well as the original) +we can specialise $j2, and similarly $j3. Even if we make just *one* +specialisation of each, becuase we also have the original we'll get 2^n +copies of $j3, which is not good. + +So when recursively specialising we divide the sc_count by the number of +copies we are making at this level, including the original. + %************************************************************************ %* * @@ -658,11 +913,6 @@ combineUsages :: [ScUsage] -> ScUsage combineUsages [] = nullUsage combineUsages us = foldr1 combineUsage us -lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc) -lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr - = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr}, - lookupVarEnv sc_occs bndr `orElse` NoOcc) - lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc]) lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs}, @@ -671,12 +921,13 @@ lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument | UnkOcc -- Used in some unknown way - | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc] - - | BothOcc -- Definitely taken apart, *and* perhaps used in some other way + | ScrutOcc -- See Note [ScrutOcc] + (DataConEnv [ArgOcc]) -- How the sub-components are used -{- Note [ScrutOcc] +type DataConEnv a = UniqFM a -- Keyed by DataCon +{- Note [ScrutOcc] +~~~~~~~~~~~~~~~~~~~ An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing, is *only* taken apart or applied. @@ -696,9 +947,11 @@ A pattern binds b, x::a, y::b, z::b->a, but not 'a'! instance Outputable ArgOcc where ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs ppr UnkOcc = ptext (sLit "unk-occ") - ppr BothOcc = ptext (sLit "both-occ") ppr NoOcc = ptext (sLit "no-occ") +evalScrutOcc :: ArgOcc +evalScrutOcc = ScrutOcc emptyUFM + -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so -- that if the thing is scrutinised anywhere then we get to see that -- in the overall result, even if it's also used in a boxed way @@ -707,10 +960,9 @@ combineOcc :: ArgOcc -> ArgOcc -> ArgOcc combineOcc NoOcc occ = occ combineOcc occ NoOcc = occ combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys) -combineOcc _occ (ScrutOcc ys) = ScrutOcc ys -combineOcc (ScrutOcc xs) _occ = ScrutOcc xs +combineOcc UnkOcc (ScrutOcc ys) = ScrutOcc ys +combineOcc (ScrutOcc xs) UnkOcc = ScrutOcc xs combineOcc UnkOcc UnkOcc = UnkOcc -combineOcc _ _ = BothOcc combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc] combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys @@ -725,16 +977,6 @@ setScrutOcc env usg (Var v) occ | otherwise = usg setScrutOcc _env usg _other _occ -- Catch-all = usg - -conArgOccs :: ArgOcc -> AltCon -> [ArgOcc] --- Find usage of components of data con; returns [UnkOcc...] if unknown --- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case - -conArgOccs (ScrutOcc fm) (DataAlt dc) - | Just pat_arg_occs <- lookupUFM fm dc - = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs - -conArgOccs _other _con = repeat UnkOcc \end{code} %************************************************************************ @@ -755,15 +997,16 @@ scExpr env e = scExpr' env e scExpr' env (Var v) = case scSubstId env v of - Var v' -> return (varUsage env v' UnkOcc, Var v') + Var v' -> return (mkVarUsage env v' [], Var v') e' -> scExpr (zapScSubst env) e' scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t)) +scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c)) scExpr' _ e@(Lit {}) = return (nullUsage, e) scExpr' env (Note n e) = do (usg,e') <- scExpr env e return (usg, Note n e') scExpr' env (Cast e co) = do (usg, e') <- scExpr env e - return (usg, Cast e' (scSubstTy env co)) + return (usg, Cast e' (scSubstCo env co)) scExpr' env e@(App _ _) = scApp env (collectArgs e) scExpr' env (Lam b e) = do let (env', b') = extendBndr env b (usg, e') <- scExpr env' e @@ -789,82 +1032,98 @@ scExpr' env (Case scrut b ty alts) ; (alt_usgs, alt_occs, alts') <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts - ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b' - scrut_occ = foldr combineOcc b_occ alt_occs - scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ + ; let scrut_occ = foldr1 combineOcc alt_occs -- Never empty + scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ -- The combined usage of the scrutinee is given -- by scrut_occ, which is passed to scScrut, which -- in turn treats a bare-variable scrutinee specially - ; return (alt_usg `combineUsage` scrut_usg', + ; return (foldr combineUsage scrut_usg' alt_usgs, Case scrut' b' (scSubstTy env ty) alts') } - sc_alt env _scrut' b' (con,bs,rhs) - = do { let (env1, bs1) = extendBndrsWith RecArg env bs - (env2, bs2) = extendCaseBndrs env1 b' con bs1 - ; (usg,rhs') <- scExpr env2 rhs - ; let (usg', arg_occs) = lookupOccs usg bs2 + sc_alt env scrut' b' (con,bs,rhs) + = do { let (env1, bs1) = extendBndrsWith RecArg env bs + (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 + ; (usg, rhs') <- scExpr env2 rhs + ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2) scrut_occ = case con of DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) _ -> ScrutOcc emptyUFM - ; return (usg', scrut_occ, (con, bs2, rhs')) } + ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) } scExpr' env (Let (NonRec bndr rhs) body) | isTyVar bndr -- Type-lets may be created by doBeta = scExpr' (extendScSubst env bndr rhs) body - | otherwise + + | otherwise = do { let (body_env, bndr') = extendBndr env bndr - ; (rhs_usg, (_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs) - ; let rhs' = mkLams args' rhs_body' - - ; if not opt_SpecInlineJoinPoints || null args' || isEmptyVarEnv (scu_calls rhs_usg) then do - do { -- Vanilla case - let body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs') - -- Record if the RHS is a value - ; (body_usg, body') <- scExpr body_env2 body - ; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') } - else -- For now, just brutally inline the join point - do { let body_env2 = extendScSubst env bndr rhs' - ; scExpr body_env2 body } } - + ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs) + + ; let body_env2 = extendHowBound body_env [bndr'] RecFun + -- Note [Local let bindings] + RI _ rhs' _ _ _ = rhs_info + body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') -{- Old code - do { -- Join-point case - let body_env2 = extendHowBound body_env [bndr'] RecFun - -- If the RHS of this 'let' contains calls - -- to recursive functions that we're trying - -- to specialise, then treat this let too - -- as one to specialise - ; (body_usg, body') <- scExpr body_env2 body + ; (body_usg, body') <- scExpr body_env3 body - ; (spec_usg, _, specs) <- specialise env (scu_calls body_usg) ([], rhs_info) + -- NB: For non-recursive bindings we inherit sc_force flag from + -- the parent function (see Note [Forcing specialisation]) + ; (spec_usg, specs) <- specialise env + (scu_calls body_usg) + rhs_info + (SI [] 0 (Just rhs_usg)) - ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } - `combineUsage` rhs_usg `combineUsage` spec_usg, - mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body') + ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } + `combineUsage` rhs_usg `combineUsage` spec_usg, + mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body') } --} + -- A *local* recursive group: see Note [Local recursive groups] scExpr' env (Let (Rec prs) body) = do { let (bndrs,rhss) = unzip prs (rhs_env1,bndrs') = extendRecBndrs env bndrs rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun + force_spec = any (forceSpecBndr env) bndrs' + -- Note [Forcing specialisation] ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss) ; (body_usg, body') <- scExpr rhs_env2 body -- NB: start specLoop from body_usg - ; (spec_usg, specs) <- specLoop rhs_env2 (scu_calls body_usg) rhs_infos nullUsage + ; (spec_usg, specs) <- specLoop (scForce rhs_env2 force_spec) + (scu_calls body_usg) rhs_infos nullUsage [SI [] 0 (Just usg) | usg <- rhs_usgs] + -- Do not unconditionally generate specialisations from rhs_usgs + -- Instead use them only if we find an unspecialised call + -- See Note [Local recursive groups] - ; let all_usg = spec_usg `combineUsage` body_usg - bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs)) + ; let rhs_usg = combineUsages rhs_usgs + all_usg = spec_usg `combineUsage` rhs_usg `combineUsage` body_usg + bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs)) ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' }, Let bind' body') } +\end{code} + +Note [Local let bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~ +It is not uncommon to find this + + let $j = \x. in ...$j True...$j True... + +Here $j is an arbitrary let-bound function, but it often comes up for +join points. We might like to specialise $j for its call patterns. +Notice the difference from a letrec, where we look for call patterns +in the *RHS* of the function. Here we look for call patterns in the +*body* of the let. ------------------------------------ +At one point I predicated this on the RHS mentioning the outer +recursive function, but that's not essential and might even be +harmful. I'm not sure. + + +\begin{code} scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr) scApp env (Var fn, args) -- Function is a variable @@ -876,15 +1135,8 @@ scApp env (Var fn, args) -- Function is a variable fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args') -- Do beta-reduction and try again - Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args') - where - fn_usg = case lookupHowBound env fn' of - Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')], - scu_occs = emptyVarEnv } - Just RecArg -> SCU { scu_calls = emptyVarEnv, - scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) } - Nothing -> nullUsage - + Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args', + mkApps (Var fn') args') other_fn' -> return (arg_usg, mkApps other_fn' args') } -- NB: doing this ignores any usage info from the substituted @@ -906,9 +1158,24 @@ scApp env (other_fn, args) ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') } ---------------------- +mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage +mkVarUsage env fn args + = case lookupHowBound env fn of + Just RecFun -> SCU { scu_calls = unitVarEnv fn [(sc_vals env, args)] + , scu_occs = emptyVarEnv } + Just RecArg -> SCU { scu_calls = emptyVarEnv + , scu_occs = unitVarEnv fn arg_occ } + Nothing -> nullUsage + where + -- I rather think we could use UnkOcc all the time + arg_occ | null args = UnkOcc + | otherwise = evalScrutOcc + +---------------------- scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind) scTopBind env (Rec prs) | Just threshold <- sc_size env + , not force_spec , not (all (couldBeSmallEnoughToInline threshold) rhss) -- No specialisation = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs @@ -921,13 +1188,16 @@ scTopBind env (Rec prs) ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss) ; let rhs_usg = combineUsages rhs_usgs - ; (_, specs) <- specLoop rhs_env2 (scu_calls rhs_usg) rhs_infos nullUsage + ; (_, specs) <- specLoop (scForce rhs_env2 force_spec) + (scu_calls rhs_usg) rhs_infos nullUsage [SI [] 0 Nothing | _ <- bndrs] ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business Rec (concat (zipWith specInfoBinds rhs_infos specs))) } where (bndrs,rhss) = unzip prs + force_spec = any (forceSpecBndr env) bndrs + -- Note [Forcing specialisation] scTopBind env (NonRec bndr rhs) = do { (_, rhs') <- scExpr env rhs @@ -942,8 +1212,8 @@ scRecRhs env (bndr,rhs) (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs ; (body_usg, body') <- scExpr body_env body ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs' - ; return (rhs_usg, (bndr, arg_bndrs', body', arg_occs)) } - + ; return (rhs_usg, RI bndr (mkLams arg_bndrs' body') + arg_bndrs body arg_occs) } -- The arg_occs says how the visible, -- lambda-bound binders of the RHS are used -- (including the TyVar binders) @@ -951,18 +1221,14 @@ scRecRhs env (bndr,rhs) ---------------------- specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)] -specInfoBinds (fn, args, body, _) (SI specs _ _) +specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _) = [(id,rhs) | OS _ _ id rhs <- specs] ++ - [(fn `addIdSpecialisations` rules, mkLams args body)] + -- First the specialised bindings + + [(fn `addIdSpecialisations` rules, new_rhs)] + -- And now the original binding where rules = [r | OS _ r _ _ <- specs] - ----------------------- -varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage -varUsage env v use - | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv - , scu_occs = unitVarEnv v use } - | otherwise = nullUsage \end{code} @@ -973,17 +1239,24 @@ varUsage env v use %************************************************************************ \begin{code} -type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc]) - -- Info about the *original* RHS of a binding we are specialising - -- Original binding f = \xs.body - -- Plus info about usage of arguments +data RhsInfo = RI OutId -- The binder + OutExpr -- The new RHS + [InVar] InExpr -- The *original* RHS (\xs.body) + -- Note [Specialise original body] + [ArgOcc] -- Info on how the xs occur in body data SpecInfo = SI [OneSpec] -- The specialisations we have generated + Int -- Length of specs; used for numbering them - (Maybe ScUsage) -- Nothing => we have generated specialisations - -- from calls in the *original* RHS - -- Just cs => we haven't, and this is the usage - -- of the original RHS + + (Maybe ScUsage) -- Just cs => we have not yet used calls in the + -- from calls in the *original* RHS as + -- seeds for new specialisations; + -- if you decide to do so, here is the + -- RHS usage (which has not yet been + -- unleashed) + -- Nothing => we have + -- See Note [Local recursive groups] -- One specialisation: Rule plus definition data OneSpec = OS CallPat -- Call pattern that generated this specialisation @@ -996,6 +1269,7 @@ specLoop :: ScEnv -> [RhsInfo] -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto... + specLoop env all_calls rhs_infos usg_so_far specs_so_far = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far ; let (new_usg_s, all_specs) = unzip specs_w_usg @@ -1014,30 +1288,40 @@ specialise -> SpecInfo -- Original RHS plus patterns dealt with -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage +-- Note: this only generates *specialised* bindings +-- The original binding is added by specInfoBinds +-- -- Note: the rhs here is the optimised version of the original rhs -- So when we make a specialised copy of the RHS, we're starting -- from an RHS whose nested functions have been optimised already. -specialise env bind_calls (fn, arg_bndrs, body, arg_occs) - spec_info@(SI specs spec_count mb_unspec) +specialise env bind_calls (RI fn _ arg_bndrs body arg_occs) + spec_info@(SI specs spec_count mb_unspec) | not (isBottomingId fn) -- Note [Do not specialise diverging functions] + , not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation] , notNull arg_bndrs -- Only specialise functions , Just all_calls <- lookupVarEnv bind_calls fn = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls --- ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs, --- text "calls" <+> ppr all_calls, --- text "good pats" <+> ppr pats]) $ +-- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns" +-- , text "arg_occs" <+> ppr arg_occs +-- , text "calls" <+> ppr all_calls +-- , text "good pats" <+> ppr pats]) $ -- return () -- Bale out if too many specialisations - -- Rather a hacky way to do so, but it'll do for now - ; let spec_count' = length pats + spec_count + ; let n_pats = length pats + spec_count' = n_pats + spec_count ; case sc_count env of - Just max | spec_count' > max - -> WARN( True, msg ) return (nullUsage, spec_info) + Just max | not (sc_force env) && spec_count' > max + -> if (debugIsOn || opt_PprStyle_Debug) -- Suppress this scary message for + then pprTrace "SpecConstr" msg $ -- ordinary users! Trac #5125 + return (nullUsage, spec_info) + else return (nullUsage, spec_info) where - msg = vcat [ sep [ ptext (sLit "SpecConstr: specialisation of") <+> quotes (ppr fn) - , nest 2 (ptext (sLit "limited by bound of")) <+> int max ] + msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn) + , nest 2 (ptext (sLit "has") <+> + speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+> + ptext (sLit "but the limit is") <+> int max) ] , ptext (sLit "Use -fspec-constr-count=n to set the bound") , extra ] extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations") @@ -1045,8 +1329,10 @@ specialise env bind_calls (fn, arg_bndrs, body, arg_occs) _normal_case -> do { - (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body) + let spec_env = decreaseSpecCount env n_pats + ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body) (pats `zip` [spec_count..]) + -- See Note [Specialise original body] ; let spec_usg = combineUsages spec_usgs (new_usg, mb_unspec') @@ -1062,8 +1348,8 @@ specialise env bind_calls (fn, arg_bndrs, body, arg_occs) --------------------- spec_one :: ScEnv -> OutId -- Function - -> [Var] -- Lambda-binders of RHS; should match patterns - -> CoreExpr -- Body of the original function + -> [InVar] -- Lambda-binders of RHS; should match patterns + -> InExpr -- Body of the original function -> (CallPat, Int) -> UniqSM (ScUsage, OneSpec) -- Rule and binding @@ -1090,44 +1376,110 @@ spec_one :: ScEnv -} spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) - = do { -- Specialise the body - let spec_env = extendScSubstList (extendScInScope env qvars) + = do { spec_uniq <- getUniqueUs + ; let spec_env = extendScSubstList (extendScInScope env qvars) (arg_bndrs `zip` pats) + fn_name = idName fn + fn_loc = nameSrcSpan fn_name + spec_occ = mkSpecOcc (nameOccName fn_name) + rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number)) + spec_name = mkInternalName spec_uniq spec_occ fn_loc +-- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $ +-- return () + + -- Specialise the body ; (spec_usg, spec_body) <- scExpr spec_env body --- ; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats, --- text "calls" <+> (ppr (scu_calls spec_usg))]) --- (return ()) +-- ; pprTrace "done spec_one}" (ppr fn) $ +-- return () -- And build the results - ; spec_uniq <- getUniqueUs - ; let (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty + ; let spec_id = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty) + `setIdStrictness` spec_str -- See Note [Transfer strictness] + `setIdArity` count isId spec_lam_args + spec_str = calcSpecStrictness fn spec_lam_args pats + (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty -- Usual w/w hack to avoid generating -- a spec_rhs of unlifted type and no args - - fn_name = idName fn - fn_loc = nameSrcSpan fn_name - spec_occ = mkSpecOcc (nameOccName fn_name) - rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number)) - spec_rhs = mkLams spec_lam_args spec_body - spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc - body_ty = exprType spec_body - rule_rhs = mkVarApps (Var spec_id) spec_call_args - rule = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs + + spec_rhs = mkLams spec_lam_args spec_body + body_ty = exprType spec_body + rule_rhs = mkVarApps (Var spec_id) spec_call_args + inline_act = idInlineActivation fn + rule = mkRule True {- Auto -} True {- Local -} + rule_name inline_act fn_name qvars pats rule_rhs + -- See Note [Transfer activation] ; return (spec_usg, OS call_pat rule spec_id spec_rhs) } --- In which phase should the specialise-constructor rules be active? --- Originally I made them always-active, but Manuel found that --- this defeated some clever user-written rules. So Plan B --- is to make them active only in Phase 0; after all, currently, --- the specConstr transformation is only run after the simplifier --- has reached Phase 0. In general one would want it to be --- flag-controllable, but for now I'm leaving it baked in --- [SLPJ Oct 01] -specConstrActivation :: Activation -specConstrActivation = ActiveAfter 0 -- Baked in; see comments above +calcSpecStrictness :: Id -- The original function + -> [Var] -> [CoreExpr] -- Call pattern + -> StrictSig -- Strictness of specialised thing +-- See Note [Transfer strictness] +calcSpecStrictness fn qvars pats + = StrictSig (mkTopDmdType spec_dmds TopRes) + where + spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ] + StrictSig (DmdType _ dmds _) = idStrictness fn + + dmd_env = go emptyVarEnv dmds pats + + go env ds (Type {} : pats) = go env ds pats + go env ds (Coercion {} : pats) = go env ds pats + go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats + go env _ _ = env + + go_one env d (Var v) = extendVarEnv_C both env v d + go_one env (Box d) e = go_one env d e + go_one env (Eval (Prod ds)) e + | (Var _, args) <- collectArgs e = go env ds args + go_one env _ _ = env + \end{code} +Note [Specialise original body] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RhsInfo for a binding keeps the *original* body of the binding. We +must specialise that, *not* the result of applying specExpr to the RHS +(which is also kept in RhsInfo). Otherwise we end up specialising a +specialised RHS, and that can lead directly to exponential behaviour. + +Note [Transfer activation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + This note is for SpecConstr, but exactly the same thing + happens in the overloading specialiser; see + Note [Auto-specialisation and RULES] in Specialise. + +In which phase should the specialise-constructor rules be active? +Originally I made them always-active, but Manuel found that this +defeated some clever user-written rules. Then I made them active only +in Phase 0; after all, currently, the specConstr transformation is +only run after the simplifier has reached Phase 0, but that meant +that specialisations didn't fire inside wrappers; see test +simplCore/should_compile/spec-inline. + +So now I just use the inline-activation of the parent Id, as the +activation for the specialiation RULE, just like the main specialiser; + +This in turn means there is no point in specialising NOINLINE things, +so we test for that. + +Note [Transfer strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must transfer strictness information from the original function to +the specialised one. Suppose, for example + + f has strictness SS + and a RULE f (a:as) b = f_spec a as b + +Now we want f_spec to have strictess LLS, otherwise we'll use call-by-need +when calling f_spec instead of call-by-value. And that can result in +unbounded worsening in space (cf the classic foldl vs foldl') + +See Trac #3437 for a good example. + +The function calcSpecStrictness performs the calculation. + + %************************************************************************ %* * \subsection{Argument analysis} @@ -1141,7 +1493,6 @@ they are constructor applications. \begin{code} type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments - callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat]) -- Result has no duplicate patterns, -- nor ones mentioned in done_pats @@ -1149,7 +1500,7 @@ callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPa callsToPats env done_specs bndr_occs calls = do { mb_pats <- mapM (callToPats env bndr_occs) calls - ; let good_pats :: [([Var], [CoreArg])] + ; let good_pats :: [CallPat] good_pats = catMaybes mb_pats done_pats = [p | OS p _ _ _ <- done_specs] is_done p = any (samePat p) done_pats @@ -1167,9 +1518,8 @@ callToPats env bndr_occs (con_env, args) = return Nothing | otherwise = do { let in_scope = substInScope (sc_subst env) - ; prs <- argsToPats in_scope con_env (args `zip` bndr_occs) - ; let (interesting_s, pats) = unzip prs - pat_fvs = varSetElems (exprsFreeVars pats) + ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs + ; let pat_fvs = varSetElems (exprsFreeVars pats) qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs -- Quantify over variables that are not in sccpe -- at the call site @@ -1181,7 +1531,7 @@ callToPats env bndr_occs (con_env, args) -- variable may mention a type variable ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $ - if or interesting_s + if interesting then return (Just (qvars', pats)) else return Nothing } @@ -1191,14 +1541,16 @@ callToPats env bndr_occs (con_env, args) -- placeholder variables. For example: -- C a (D (f x) (g y)) ==> C p1 (D p2 p3) -argToPat :: InScopeSet -- What's in scope at the fn defn site +argToPat :: ScEnv + -> InScopeSet -- What's in scope at the fn defn site -> ValueEnv -- ValueEnv at the call site -> CoreArg -- A call arg (or component thereof) -> ArgOcc -> UniqSM (Bool, CoreArg) + -- Returns (interesting, pat), -- where pat is the pattern derived from the argument --- intersting=True if the pattern is non-trivial (not a variable or type) +-- interesting=True if the pattern is non-trivial (not a variable or type) -- E.g. x:xs --> (True, x:xs) -- f xs --> (False, w) where w is a fresh wildcard -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard @@ -1206,11 +1558,14 @@ argToPat :: InScopeSet -- What's in scope at the fn defn site -- lvl7 --> (True, lvl7) if lvl7 is bound -- somewhere further out -argToPat _in_scope _val_env arg@(Type {}) _arg_occ +argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ + = return (False, arg) + +argToPat _env _in_scope _val_env arg@(Coercion {}) _arg_occ = return (False, arg) -argToPat in_scope val_env (Note _ arg) arg_occ - = argToPat in_scope val_env arg arg_occ +argToPat env in_scope val_env (Note _ arg) arg_occ + = argToPat env in_scope val_env arg arg_occ -- Note [Notes in call patterns] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Ignore Notes. In particular, we want to ignore any InlineMe notes @@ -1218,24 +1573,38 @@ argToPat in_scope val_env (Note _ arg) arg_occ -- ride roughshod over them all for now. --- See Note [Notes in RULE matching] in Rules -argToPat in_scope val_env (Let _ arg) arg_occ - = argToPat in_scope val_env arg arg_occ +argToPat env in_scope val_env (Let _ arg) arg_occ + = argToPat env in_scope val_env arg arg_occ + -- See Note [Matching lets] in Rule.lhs -- Look through let expressions - -- e.g. f (let v = rhs in \y -> ...v...) - -- Here we can specialise for f (\y -> ...) + -- e.g. f (let v = rhs in (v,w)) + -- Here we can specialise for f (v,w) -- because the rule-matcher will look through the let. -argToPat in_scope val_env (Cast arg co) arg_occ - = do { (interesting, arg') <- argToPat in_scope val_env arg arg_occ - ; let (ty1,ty2) = coercionKind co +{- Disabled; see Note [Matching cases] in Rule.lhs +argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ + | exprOkForSpeculation scrut -- See Note [Matching cases] in Rule.hhs + = argToPat env in_scope val_env rhs arg_occ +-} + +argToPat env in_scope val_env (Cast arg co) arg_occ + | isReflCo co -- Substitution in the SpecConstr itself + -- can lead to identity coercions + = argToPat env in_scope val_env arg arg_occ + | not (ignoreType env ty2) + = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ ; if not interesting then wildCardPat ty2 else do { -- Make a wild-card pattern for the coercion uniq <- getUniqueUs ; let co_name = mkSysTvName uniq (fsLit "sg") - co_var = mkCoVar co_name (mkCoKind ty1 ty2) - ; return (interesting, Cast arg' (mkTyVarTy co_var)) } } + co_var = mkCoVar co_name (mkCoType ty1 ty2) + ; return (interesting, Cast arg' (mkCoVarCo co_var)) } } + where + Pair ty1 ty2 = coercionKind co + + {- Disabling lambda specialisation for now It's fragile, and the spec_loop can be infinite @@ -1251,25 +1620,30 @@ argToPat in_scope val_env arg arg_occ -- Check for a constructor application -- NB: this *precedes* the Var case, so that we catch nullary constrs -argToPat in_scope val_env arg arg_occ - | Just (ConVal dc args) <- isValue val_env arg - , case arg_occ of - ScrutOcc _ -> True -- Used only by case scrutinee - BothOcc -> case arg of -- Used elsewhere - App {} -> True -- see Note [Reboxing] - _other -> False - _other -> False -- No point; the arg is not decomposed - = do { args' <- argsToPats in_scope val_env (args `zip` conArgOccs arg_occ dc) - ; return (True, mk_con_app dc (map snd args')) } +argToPat env in_scope val_env arg arg_occ + | Just (ConVal (DataAlt dc) args) <- isValue val_env arg + , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] + , Just arg_occs <- mb_scrut dc + = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args + ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs + ; return (True, + mkConApp dc (ty_args ++ args')) } + where + mb_scrut dc = case arg_occ of + ScrutOcc bs + | Just occs <- lookupUFM bs dc + -> Just (occs) -- See Note [Reboxing] + _other | sc_force env -> Just (repeat UnkOcc) + | otherwise -> Nothing -- Check if the argument is a variable that - -- is in scope at the function definition site - -- It's worth specialising on this if - -- (a) it's used in an interesting way in the body + -- (a) is used in an interesting way in the body -- (b) we know what its value is -argToPat in_scope val_env (Var v) arg_occ - | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) - is_value -- (b) + -- In that case it counts as "interesting" +argToPat env in_scope val_env (Var v) arg_occ + | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) + is_value, -- (b) + not (ignoreType env (varType v)) = return (True, Var v) where is_value @@ -1298,21 +1672,22 @@ argToPat in_scope val_env (Var v) arg_occ -- We don't want to specialise for that *particular* x,y -- The default case: make a wild-card -argToPat _in_scope _val_env arg _arg_occ +argToPat _env _in_scope _val_env arg _arg_occ = wildCardPat (exprType arg) wildCardPat :: Type -> UniqSM (Bool, CoreArg) -wildCardPat ty = do { uniq <- getUniqueUs - ; let id = mkSysLocal (fsLit "sc") uniq ty - ; return (False, Var id) } - -argsToPats :: InScopeSet -> ValueEnv - -> [(CoreArg, ArgOcc)] - -> UniqSM [(Bool, CoreArg)] -argsToPats in_scope val_env args - = mapM do_one args - where - do_one (arg,occ) = argToPat in_scope val_env arg occ +wildCardPat ty + = do { uniq <- getUniqueUs + ; let id = mkSysLocal (fsLit "sc") uniq ty + ; return (False, Var id) } + +argsToPats :: ScEnv -> InScopeSet -> ValueEnv + -> [CoreArg] -> [ArgOcc] -- Should be same length + -> UniqSM (Bool, [CoreArg]) +argsToPats env in_scope val_env args occs + = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs + ; let (interesting_s, args') = unzip stuff + ; return (or interesting_s, args') } \end{code} @@ -1357,11 +1732,6 @@ isValue _env expr -- Maybe it's a constructor application isValue _env _expr = Nothing -mk_con_app :: AltCon -> [CoreArg] -> CoreExpr -mk_con_app (LitAlt lit) [] = Lit lit -mk_con_app (DataAlt con) args = mkConApp con args -mk_con_app _other _args = panic "SpecConstr.mk_con_app" - samePat :: CallPat -> CallPat -> Bool samePat (vs1, as1) (vs2, as2) = all2 same as1 as2 @@ -1375,6 +1745,7 @@ samePat (vs1, as1) (vs2, as2) same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2 same (Type {}) (Type {}) = True -- Note [Ignore type differences] + same (Coercion {}) (Coercion {}) = True same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes same (Cast e1 _) e2 = same e1 e2 same e1 (Note _ e2) = same e1 e2