X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecConstr.lhs;h=92e4131c95f58ccb16f56cbf18390082f49639d2;hb=526a19e90100eadb36185f3bd2c6ac263b7d25ad;hp=d3943140fb202857511267804785b5e3f3567ea9;hpb=d8a34b36969e4c41a727b4678d6049266f7a1c58;p=ghc-hetmet.git diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index d394314..92e4131 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -115,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 @@ -125,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] ~~~~~~~~~~~~~~~~~~~~~ @@ -466,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 @@ -478,11 +503,12 @@ 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 @@ -492,18 +518,10 @@ extendCaseBndrs env case_bndr scrut con alt_bndrs -- 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 = get_how scrut - where - get_how (Var v) = lookupVarEnv cur_scope v `orElse` Other - get_how (Cast e _) = get_how e - get_how (Note _ e) = get_how e - get_how 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 @@ -512,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} @@ -532,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 @@ -593,10 +603,10 @@ instance Outputable ArgOcc where ppr BothOcc = ptext SLIT("both-occ") ppr NoOcc = ptext SLIT("no-occ") --- Experimentally, this vresion of combineOcc makes ScrutOcc "win", so +-- 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] +-- 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) @@ -683,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 @@ -704,36 +715,38 @@ 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 @@ -750,18 +763,22 @@ 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 - all_calls = lookupVarEnv (calls body_usg) fn `orElse` [] - - ; mb_pats <- mapM (callToPats (scope env) bndr_occs) all_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 @@ -769,12 +786,19 @@ specialise env fn bndrs body body_usg [ exprsFreeVars pats `delVarSetList` vs | (vs,pats) <- good_pats ] uniq_pats = nubBy (same_pat in_scope) good_pats - ; -- pprTrace "specialise" (vcat [ppr fn <+> ppr bndrs <+> ppr bndr_occs, - -- text "calls" <+> ppr all_calls, - -- text "good pats" <+> ppr good_pats, - -- text "uniq pats" <+> ppr uniq_pats]) $ - mapAndUnzipUs (spec_one env fn (mkLams bndrs body)) - (uniq_pats `zip` [1..]) } +-- ; 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 pats are the same if they match both ways same_pat in_scope (vs1,as1)(vs2,as2) @@ -802,8 +826,7 @@ callToPats in_scope bndr_occs (con_env, args) 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 @@ -829,7 +852,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 @@ -902,18 +925,6 @@ 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 (Let _ arg) arg_occ = argToPat in_scope con_env arg arg_occ -- Look through let expressions @@ -937,6 +948,8 @@ 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 @@ -948,15 +961,27 @@ argToPat in_scope con_env arg arg_occ = 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 + | not (isLocalId v) || v `elemVarEnv` in_scope, + case arg_occ of { UnkOcc -> False; other -> True }, -- (a) + isValueUnfolding (idUnfolding v) -- (b) + = return (True, Var v) + + -- 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 - = -- 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) + = 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 @@ -975,33 +1000,30 @@ 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