X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecConstr.lhs;h=b5ae45f0137d2a62c27d5472a8ab934af5b9ba18;hb=45ee1c1b1c0fab2e8ac8ad584bee0fc6087e5711;hp=1ee5935fa024c57f119b0de7d699aeb6f8c49954;hpb=6be927feb4c910a59990b5d2c32e0c41c3a2a95b;p=ghc-hetmet.git diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 1ee5935..b5ae45f 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -14,13 +14,12 @@ import CoreSyn import CoreLint ( showPass, endPass ) import CoreUtils ( exprType, mkPiTypes ) import CoreFVs ( exprsFreeVars ) -import CoreSubst ( Subst, mkSubst, substExpr ) import CoreTidy ( tidyRules ) import PprCore ( pprRules ) import WwLib ( mkWorkerArgs ) -import DataCon ( dataConRepArity, isVanillaDataCon, - dataConUnivTyVars ) -import Type ( Type, tyConAppArgs, tyVarsOfTypes ) +import DataCon ( dataConRepArity, dataConUnivTyVars ) +import Type ( Type, tyConAppArgs ) +import Coercion ( coercionKind ) import Rules ( matchN ) import Id ( Id, idName, idType, isDataConWorkId_maybe, mkUserLocal, mkSysLocal, idUnfolding, isLocalId ) @@ -116,7 +115,7 @@ This happens if Hence the "OR" part of Note [Good arguments] below. -ALTERNATIVE: pass both boxed and unboxed versions. This no longer saves +ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves allocation, but does perhaps save evals. In the RULE we'd have something like @@ -126,6 +125,25 @@ If at the call site the (I# x) was an unfolding, then we'd have to rely on CSE to eliminate the duplicate allocation.... This alternative doesn't look attractive enough to pursue. +ALTERNATIVE 3: ignore the reboxing problem. The trouble is that +the conservative reboxing story prevents many useful functions from being +specialised. Example: + foo :: Maybe Int -> Int -> Int + foo (Just m) 0 = 0 + foo x@(Just m) n = foo x (n-m) +Here the use of 'x' will clearly not require boxing in the specialised function. + +The strictness analyser has the same problem, in fact. Example: + f p@(a,b) = ... +If we pass just 'a' and 'b' to the worker, it might need to rebox the +pair to create (a,b). A more sophisticated analysis might figure out +precisely the cases in which this could happen, but the strictness +analyser does no such analysis; it just passes 'a' and 'b', and hopes +for the best. + +So my current choice is to make SpecConstr similarly aggressive, and +ignore the bad potential of reboxing. + Note [Good arguments] ~~~~~~~~~~~~~~~~~~~~~ @@ -300,6 +318,24 @@ may avoid allocating it altogether. Just like for constructors. Looks cool, but probably rare...but it might be easy to implement. + +Note [SpecConstr for casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a :: * + data instance T Int = T Int + + foo n = ... + where + go (T 0) = 0 + go (T n) = go (T (n-1)) + +The recursive call ends up looking like + go (T (I# ...) `cast` g) +So we want to spot the construtor application inside the cast. +That's why we have the Cast case in argToPat + + ----------------------------------------------------- Stuff not yet handled ----------------------------------------------------- @@ -429,12 +465,6 @@ data ConValue = CV AltCon [CoreArg] instance Outputable ConValue where ppr (CV con args) = ppr con <+> interpp'SP args -refineConstrEnv :: Subst -> ConstrEnv -> ConstrEnv --- The substitution is a type substitution only -refineConstrEnv subst env = mapVarEnv refine_con_value env - where - refine_con_value (CV con args) = CV con (map (substExpr subst) args) - emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv } data HowBound = RecFun -- These are the recursive functions for which @@ -455,7 +485,13 @@ instance Outputable HowBound where lookupScopeEnv env v = lookupVarEnv (scope env) v -extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] } + +extendBndrsWith :: HowBound -> ScEnv -> [Var] -> ScEnv +extendBndrsWith how_bound env bndrs + = env { scope = scope env `extendVarEnvList` + [(bndr,how_bound) | bndr <- bndrs] } + +extendBndrs env bndrs = extendBndrsWith Other env bndrs extendBndr env bndr = env { scope = extendVarEnv (scope env) bndr Other } -- When we encounter @@ -467,27 +503,25 @@ extendCaseBndrs env case_bndr scrut con alt_bndrs = case con of DEFAULT -> env1 LitAlt lit -> extendCons env1 scrut case_bndr (CV con []) - DataAlt dc -> extend_data_con dc + DataAlt dc -> extendCons env1 scrut case_bndr (CV con vanilla_args) + where + vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ + varsToCoreExprs alt_bndrs where - cur_scope = scope env - env1 = env { scope = extendVarEnvList cur_scope - [(b,how_bound) | b <- case_bndr:alt_bndrs] } + env1 = extendBndrsWith (get_how scrut) env (case_bndr:alt_bndrs) -- Record RecArg for the components iff the scrutinee is RecArg + -- I think the only reason for this is to keep the usage envt small + -- so is it worth it at all? -- [This comment looks plain wrong to me, so I'm ignoring it -- "Also forget if the scrutinee is a RecArg, because we're -- now in the branch of a case, and we don't want to -- record a non-scrutinee use of v if we have -- case v of { (a,b) -> ...(f v)... }" ] - how_bound = case scrut of - Var v -> lookupVarEnv cur_scope v `orElse` Other - other -> Other - - extend_data_con data_con = - extendCons env1 scrut case_bndr (CV con vanilla_args) - where - vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ - varsToCoreExprs alt_bndrs + get_how (Var v) = lookupVarEnv (scope env) v `orElse` Other + get_how (Cast e _) = get_how e + get_how (Note _ e) = get_how e + get_how other = Other extendCons :: ScEnv -> CoreExpr -> Id -> ConValue -> ScEnv extendCons env scrut case_bndr val @@ -496,14 +530,6 @@ extendCons env scrut case_bndr val other -> env { cons = cons1 } where cons1 = extendVarEnv (cons env) case_bndr val - - -- When we encounter a recursive function binding - -- f = \x y -> ... - -- we want to extend the scope env with bindings - -- that record that f is a RecFn and x,y are RecArgs -extendRecBndr env fn bndrs - = env { scope = scope env `extendVarEnvList` - ((fn,RecFun): [(bndr,RecArg) | bndr <- bndrs]) } \end{code} @@ -516,7 +542,7 @@ extendRecBndr env fn bndrs \begin{code} data ScUsage = SCU { - calls :: !(IdEnv ([Call])), -- Calls + calls :: !(IdEnv [Call]), -- Calls -- The functions are a subset of the -- RecFuns in the ScEnv @@ -555,9 +581,10 @@ data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument {- Note [ScrutOcc] -An occurrence of ScrutOcc indicates that the thing is *only* taken apart or applied. +An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing, +is *only* taken apart or applied. - Functions, litersl: ScrutOcc emptyUFM + Functions, literal: ScrutOcc emptyUFM Data constructors: ScrutOcc subs, where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components, @@ -571,14 +598,20 @@ 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") <> parens (ppr xs) + 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") +-- 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 +-- This might be too agressive; see Note [Reboxing] Alternative 3 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 UnkOcc = UnkOcc combineOcc _ _ = BothOcc @@ -591,10 +624,7 @@ conArgOccs :: ArgOcc -> AltCon -> [ArgOcc] conArgOccs (ScrutOcc fm) (DataAlt dc) | Just pat_arg_occs <- lookupUFM fm dc - = tyvar_unks ++ pat_arg_occs - where - tyvar_unks | isVanillaDataCon dc = [UnkOcc | tv <- dataConUnivTyVars dc] - | otherwise = [] + = [UnkOcc | tv <- dataConUnivTyVars dc] ++ pat_arg_occs conArgOccs other con = repeat UnkOcc \end{code} @@ -663,6 +693,7 @@ scExpr env e@(App _ _) ; (arg_usgs, args') <- mapAndUnzipUs (scExpr env) args ; let call_usg = case fn of Var f | Just RecFun <- lookupScopeEnv env f + , not (null args) -- Not a proper call! -> SCU { calls = unitVarEnv f [(cons env, args)], occs = emptyVarEnv } other -> nullUsage @@ -674,43 +705,48 @@ scExpr env e@(App _ _) ---------------------- scScrut :: ScEnv -> CoreExpr -> ArgOcc -> UniqSM (ScUsage, CoreExpr) -- Used for the scrutinee of a case, --- or the function of an application -scScrut env e@(Var v) occ = returnUs (varUsage env v occ, e) -scScrut env e occ = scExpr env e +-- or the function of an application. +-- Remember to look through casts +scScrut env e@(Var v) occ = returnUs (varUsage env v occ, e) +scScrut env (Cast e co) occ = do { (usg, e') <- scScrut env e occ + ; returnUs (usg, Cast e' co) } +scScrut env e occ = scExpr env e ---------------------- scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind) -scBind env (Rec [(fn,rhs)]) - | notNull val_bndrs - = scExpr env_fn_body body `thenUs` \ (usg, body') -> - specialise env fn bndrs body' usg `thenUs` \ (rules, spec_prs) -> - -- Note body': the specialised copies should be based on the - -- optimised version of the body, in case there were - -- nested functions inside. - let - SCU { calls = calls, occs = occs } = usg - in - returnUs (extendBndr env fn, -- For the body of the letrec, just - -- extend the env with Other to record - -- that it's in scope; no funny RecFun business - SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs}, - Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs)) - where - (bndrs,body) = collectBinders rhs - val_bndrs = filter isId bndrs - env_fn_body = extendRecBndr env fn bndrs - scBind env (Rec prs) - = mapAndUnzipUs do_one prs `thenUs` \ (usgs, prs') -> - returnUs (extendBndrs env (map fst prs), combineUsages usgs, Rec prs') - where - do_one (bndr,rhs) = scExpr env rhs `thenUs` \ (usg, rhs') -> - returnUs (usg, (bndr,rhs')) + = do { let bndrs = map fst prs + rhs_env = extendBndrsWith RecFun env bndrs + + ; (rhs_usgs, prs_w_occs) <- mapAndUnzipUs (scRecRhs rhs_env) prs + ; let rhs_usg = combineUsages rhs_usgs + rhs_calls = calls rhs_usg + + ; prs_s <- mapUs (specialise env rhs_calls) prs_w_occs + ; return (extendBndrs env bndrs, + -- For the body of the letrec, just + -- extend the env with Other to record + -- that it's in scope; no funny RecFun business + rhs_usg { calls = calls rhs_usg `delVarEnvList` bndrs }, + Rec (concat prs_s)) } scBind env (NonRec bndr rhs) - = scExpr env rhs `thenUs` \ (usg, rhs') -> - returnUs (extendBndr env bndr, usg, NonRec bndr rhs') + = do { (usg, rhs') <- scExpr env rhs + ; return (extendBndr env bndr, usg, NonRec bndr rhs') } + +---------------------- +scRecRhs :: ScEnv -> (Id,CoreExpr) + -> UniqSM (ScUsage, (Id, CoreExpr, [ArgOcc])) +-- The returned [ArgOcc] says how the visible, +-- lambda-bound binders of the RHS are used +-- (including the TyVar binders) +scRecRhs env (bndr,rhs) + = do { let (arg_bndrs,body) = collectBinders rhs + body_env = 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, mkLams arg_bndrs body', arg_occs)) } ---------------------- varUsage env v use @@ -727,33 +763,52 @@ varUsage env v use %************************************************************************ \begin{code} -specialise :: ScEnv - -> Id -- Functionn - -> [CoreBndr] -> CoreExpr -- Its RHS - -> ScUsage -- Info on usage - -> UniqSM ([CoreRule], -- Rules - [(Id,CoreExpr)]) -- Bindings - -specialise env fn bndrs body body_usg - = do { let (_, bndr_occs) = lookupOccs body_usg bndrs - - ; mb_calls <- mapM (callToPats (scope env) bndr_occs) - (lookupVarEnv (calls body_usg) fn `orElse` []) - - ; let good_calls :: [([Var], [CoreArg])] - good_calls = catMaybes mb_calls +specialise + :: ScEnv + -> IdEnv [Call] -- Info on usage + -> (Id, CoreExpr, [ArgOcc]) -- Original binding, plus info on how the rhs's + -- lambda-binders are used (includes TyVar bndrs) + -> UniqSM [(Id,CoreExpr)] -- Original binding (decorated with rules) + -- plus specialised bindings + +-- 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 calls (fn, rhs, arg_occs) + | notNull arg_occs, -- Only specialise functions + Just all_calls <- lookupVarEnv calls fn + = do { mb_pats <- mapM (callToPats (scope env) arg_occs) all_calls + + ; let good_pats :: [([Var], [CoreArg])] + good_pats = catMaybes mb_pats in_scope = mkInScopeSet $ unionVarSets $ - [ exprsFreeVars pats `delVarSetList` vs - | (vs,pats) <- good_calls ] - uniq_calls = nubBy (same_call in_scope) good_calls - in - mapAndUnzipUs (spec_one env fn (mkLams bndrs body)) - (uniq_calls `zip` [1..]) } + [ exprsFreeVars pats + | (vs,pats) <- good_pats ] + -- This in-scope set is used when matching to see if + -- we have identical patterns. We want to treat the + -- forall'd variables of each pattern as "in scope", + -- because each in turn serves as the match target for + -- a matchN call. So don't remove the 'vs' from the free vars! + uniq_pats = nubBy (same_pat in_scope) good_pats +-- ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs, +-- text "calls" <+> ppr all_calls, +-- text "good pats" <+> ppr good_pats, +-- text "uniq pats" <+> ppr uniq_pats]) $ +-- return () + + ; (rules, spec_prs) <- mapAndUnzipUs (spec_one fn rhs) + (uniq_pats `zip` [1..]) + + ; return ((fn `addIdSpecialisations` rules, rhs) : spec_prs) } + + | otherwise + = return [(fn,rhs)] -- The boring case where - -- Two calls are the same if they match both ways - same_call in_scope (vs1,as1)(vs2,as2) - = isJust (matchN in_scope vs1 as1 as2) - && isJust (matchN in_scope vs2 as2 as1) + -- Two pats are the same if they match both ways + same_pat in_scope (vs1,as1)(vs2,as2) + = isJust (matchN in_scope vs1 as1 as2) + && isJust (matchN in_scope vs2 as2 as1) callToPats :: InScopeEnv -> [ArgOcc] -> Call -> UniqSM (Maybe ([Var], [CoreExpr])) @@ -770,13 +825,13 @@ callToPats in_scope bndr_occs (con_env, args) -- Quantify over variables that are not in sccpe -- See Note [Shadowing] at the top - ; if or good_pats + ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $ + if or good_pats then return (Just (qvars, pats)) else return Nothing } --------------------- -spec_one :: ScEnv - -> Id -- Function +spec_one :: Id -- Function -> CoreExpr -- Rhs of the original function -> (([Var], [CoreArg]), Int) -> UniqSM (CoreRule, (Id,CoreExpr)) -- Rule and binding @@ -802,7 +857,7 @@ spec_one :: ScEnv f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw -} -spec_one env fn rhs ((vars_to_bind, pats), rule_number) +spec_one fn rhs ((vars_to_bind, pats), rule_number) = getUniqueUs `thenUs` \ spec_uniq -> let fn_name = idName fn @@ -875,17 +930,28 @@ argToPat :: InScopeEnv -- What's in scope at the fn defn site argToPat in_scope con_env arg@(Type ty) arg_occ = return (False, arg) -argToPat in_scope con_env (Var v) arg_occ - | not (isLocalId v) || v `elemVarEnv` in_scope - = -- The recursive call passes 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 - -- (b) we know what its value is - if (case arg_occ of { UnkOcc -> False; other -> True }) -- (a) - && isValueUnfolding (idUnfolding v) -- (b) - then return (True, Var v) - else wildCardPat (idType v) +argToPat in_scope con_env (Note n arg) arg_occ + = argToPat in_scope con_env arg arg_occ + -- Note [Notes in call patterns] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Ignore Notes. In particular, we want to ignore any InlineMe notes + -- Perhaps we should not ignore profiling notes, but I'm going to + -- ride roughshod over them all for now. + --- See Note [Notes in RULE matching] in Rules + +argToPat in_scope con_env (Let _ arg) arg_occ + = argToPat in_scope con_env arg arg_occ + -- Look through let expressions + -- e.g. f (let v = rhs in \y -> ...v...) + -- Here we can specialise for f (\y -> ...) + -- because the rule-matcher will look through the let. + +argToPat in_scope con_env (Cast arg co) arg_occ + = do { (interesting, arg') <- argToPat in_scope con_env arg arg_occ + ; if interesting then + return (interesting, Cast arg' co) + else + wildCardPat (snd (coercionKind co)) } argToPat in_scope con_env arg arg_occ | is_value_lam arg @@ -896,26 +962,46 @@ argToPat in_scope con_env arg arg_occ | otherwise = is_value_lam e is_value_lam other = False + -- Check for a constructor application + -- NB: this *precedes* the Var case, so that we catch nullary constrs argToPat in_scope con_env arg arg_occ | Just (CV dc args) <- is_con_app_maybe con_env arg , case arg_occ of ScrutOcc _ -> True -- Used only by case scrutinee - BothOcc -> case arg of -- Used by case scrut - App {} -> True -- ...and elsewhere... + 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 con_env (args `zip` conArgOccs arg_occ dc) ; return (True, mk_con_app dc (map snd args')) } + -- 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 + -- (b) we know what its value is argToPat in_scope con_env (Var v) arg_occ - = -- A variable bound inside the function. - -- Don't make a wild-card, because we may usefully share - -- e.g. f a = let x = ... in f (x,x) - -- NB: this case follows the lambda and con-app cases!! - return (False, Var v) + | not (isLocalId v) || v `elemVarEnv` in_scope, + case arg_occ of { UnkOcc -> False; other -> True }, -- (a) + isValueUnfolding (idUnfolding v) -- (b) + = return (True, Var v) + +{- I'm really not sure what this comment means + And by not wild-carding we tend to get forall'd + variables that are in soope, which in turn can + expose the weakness in let-matching + See Note [Matching lets] in Rules + -- Check for a variable bound inside the function. + -- Don't make a wild-card, because we may usefully share + -- e.g. f a = let x = ... in f (x,x) + -- NB: this case follows the lambda and con-app cases!! +argToPat in_scope con_env (Var v) arg_occ + = return (False, Var v) +-} --- The default case: make a wild-card -argToPat in_scope con_env arg arg_occ = wildCardPat (exprType arg) + -- The default case: make a wild-card +argToPat in_scope con_env arg arg_occ + = wildCardPat (exprType arg) wildCardPat :: Type -> UniqSM (Bool, CoreArg) wildCardPat ty = do { uniq <- getUniqueUs @@ -934,35 +1020,33 @@ argsToPats in_scope con_env args \begin{code} is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe ConValue +is_con_app_maybe env (Lit lit) + = Just (CV (LitAlt lit) []) + +is_con_app_maybe env expr -- Maybe it's a constructor application + | (Var fun, args) <- collectArgs expr, + Just con <- isDataConWorkId_maybe fun, + args `lengthAtLeast` dataConRepArity con + -- Might be > because the arity excludes type args + = Just (CV (DataAlt con) args) + is_con_app_maybe env (Var v) - = case lookupVarEnv env v of - Just stuff -> Just stuff - -- You might think we could look in the idUnfolding here + | Just stuff <- lookupVarEnv env v + = Just stuff -- You might think we could look in the idUnfolding here -- but that doesn't take account of which branch of a -- case we are in, which is the whole point - Nothing | isCheapUnfolding unf - -> is_con_app_maybe env (unfoldingTemplate unf) - where - unf = idUnfolding v - -- However we do want to consult the unfolding - -- as well, for let-bound constructors! - - other -> Nothing - -is_con_app_maybe env (Lit lit) - = Just (CV (LitAlt lit) []) - -is_con_app_maybe env expr - = case collectArgs expr of - (Var fun, args) | Just con <- isDataConWorkId_maybe fun, - args `lengthAtLeast` dataConRepArity con - -- Might be > because the arity excludes type args - -> Just (CV (DataAlt con) args) + | isCheapUnfolding unf + = is_con_app_maybe env (unfoldingTemplate unf) + where + unf = idUnfolding v + -- However we do want to consult the unfolding + -- as well, for let-bound constructors! - other -> Nothing +is_con_app_maybe 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" \end{code}