X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FOccurAnal.lhs;h=a37b5f16bddd97991e343d352f3d2175064d0f60;hp=d33a68ed5792c4159b13d7376e50b87390f4e56d;hb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;hpb=65277a1c9ff86c28c656849d6f6cbb392f1eb3e7 diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index d33a68e..a37b5f1 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -28,6 +28,7 @@ import BasicTypes import VarSet import VarEnv +import Var ( Var, varUnique ) import Maybes ( orElse ) import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR ) @@ -37,7 +38,7 @@ import UniqFM ( keysUFM, intersectUFM_C, foldUFM_Directly ) import Util ( mapAndUnzip, filterOut ) import Bag import Outputable - +import FastString import Data.List \end{code} @@ -91,7 +92,7 @@ occAnalBind :: OccEnv -- The incoming OccEnv [CoreBind]) occAnalBind env _ (NonRec binder rhs) body_usage - | isTyVar binder -- A type let; we don't gather usage info + | isTyCoVar binder -- A type let; we don't gather usage info = (body_usage, [NonRec binder rhs]) | not (binder `usedIn` body_usage) -- It's not mentioned @@ -314,12 +315,13 @@ occAnalBind _ env (Rec pairs) body_usage rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs make_node (bndr, rhs) - = (ND bndr rhs' all_rhs_usage rhs_fvs, idUnique bndr, out_edges) + = (ND bndr rhs' all_rhs_usage rhs_fvs, varUnique bndr, out_edges) where (rhs_usage, rhs') = occAnalRhs env bndr rhs - all_rhs_usage = addRuleUsage rhs_usage bndr -- Note [Rules are extra RHSs] - rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage - out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr) + all_rhs_usage = addIdOccs rhs_usage rule_vars -- Note [Rules are extra RHSs] + rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage + out_edges = keysUFM (rhs_fvs `unionVarSet` rule_vars) + rule_vars = idRuleVars bndr -- See Note [Rule dependency info] -- (a -> b) means a mentions b -- Given the usage details (a UFM that gives occ info for each free var of -- the RHS) we can get the list of free vars -- or rather their Int keys -- @@ -400,6 +402,7 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds) no_rules = null init_rule_fvs init_rule_fvs = [(b, rule_fvs) | b <- bndrs + , isId b , let rule_fvs = idRuleRhsVars b `intersectVarSet` bndr_set , not (isEmptyVarSet rule_fvs)] @@ -529,6 +532,8 @@ reOrderCycle depth (bind : binds) pairs score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker score (ND bndr rhs _ _, _, _) + | not (isId bndr) = 100 -- A type or cercion varialbe is never a loop breaker + | isDFunId bndr = 9 -- Never choose a DFun as a loop breaker -- Note [DFuns should not be loop breakers] @@ -582,7 +587,8 @@ reOrderCycle depth (bind : binds) pairs makeLoopBreaker :: Bool -> Id -> Id -- Set the loop-breaker flag: see Note [Weak loop breakers] -makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak) +makeLoopBreaker weak bndr + = ASSERT2( isId bndr, ppr bndr ) setIdOccInfo bndr (IAmALoopBreaker weak) \end{code} Note [Complexity of loop breaking] @@ -730,7 +736,8 @@ occAnalRhs :: OccEnv -- Returned usage details includes any INLINE rhs occAnalRhs env id rhs - = (addIdOccs rhs_usage (idUnfoldingVars id), rhs') + | isId id = (addIdOccs rhs_usage (idUnfoldingVars id), rhs') + | otherwise = (rhs_usage, rhs') -- Include occurrences for the "extra RHS" from a CoreUnfolding where (rhs_usage, rhs') = occAnal ctxt rhs @@ -759,9 +766,11 @@ occAnalRhs env id rhs \begin{code} -addRuleUsage :: UsageDetails -> Id -> UsageDetails +addRuleUsage :: UsageDetails -> Var -> UsageDetails -- Add the usage from RULES in Id to the usage -addRuleUsage usage id = addIdOccs usage (idRuleVars id) +addRuleUsage usage var + | isId var = addIdOccs usage (idRuleVars var) + | otherwise = usage -- idRuleVars here: see Note [Rule dependency info] addIdOccs :: UsageDetails -> VarSet -> UsageDetails @@ -826,7 +835,7 @@ occAnal env (Note note body) occAnal env (Cast expr co) = case occAnal env expr of { (usage, expr') -> - (markRhsUds env True usage, Cast expr' co) + (markManyIf (isRhsEnv env) usage, Cast expr' co) -- If we see let x = y `cast` co -- then mark y as 'Many' so that we don't -- immediately inline y again. @@ -841,7 +850,7 @@ occAnal env app@(App _ _) -- (a) occurrences inside type lambdas only not marked as InsideLam -- (b) type variables not in environment -occAnal env (Lam x body) | isTyVar x +occAnal env (Lam x body) | isTyCoVar x = case occAnal env body of { (body_usage, body') -> (body_usage, Lam x body') } @@ -940,7 +949,14 @@ occAnalApp :: OccEnv occAnalApp env (Var fun, args) = case args_stuff of { (args_uds, args') -> let - final_args_uds = markRhsUds env is_exp args_uds + final_args_uds = markManyIf (isRhsEnv env && is_exp) args_uds + -- We mark the free vars of the argument of a constructor or PAP + -- as "many", if it is the RHS of a let(rec). + -- This means that nothing gets inlined into a constructor argument + -- position, which is what we want. Typically those constructor + -- arguments are just variables, or trivial expressions. + -- + -- This is the *whole point* of the isRhsEnv predicate in (fun_uds +++ final_args_uds, mkApps (Var fun) args') } where @@ -981,21 +997,11 @@ occAnalApp env (fun, args) (final_uds, mkApps fun' args') }} -markRhsUds :: OccEnv -- Check if this is a RhsEnv - -> Bool -- and this is true - -> UsageDetails -- The do markMany on this +markManyIf :: Bool -- If this is true + -> UsageDetails -- Then do markMany on this -> UsageDetails --- We mark the free vars of the argument of a constructor or PAP --- as "many", if it is the RHS of a let(rec). --- This means that nothing gets inlined into a constructor argument --- position, which is what we want. Typically those constructor --- arguments are just variables, or trivial expressions. --- --- This is the *whole point* of the isRhsEnv predicate -markRhsUds env is_pap arg_uds - | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds - | otherwise = arg_uds - +markManyIf True uds = mapVarEnv markMany uds +markManyIf False uds = uds appSpecial :: OccEnv -> Int -> CtxtTy -- Argument number, and context to use for it @@ -1093,6 +1099,10 @@ data OccEncl | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. -- Do inline into constructor args here +instance Outputable OccEncl where + ppr OccRhs = ptext (sLit "occRhs") + ppr OccVanilla = ptext (sLit "occVanilla") + type CtxtTy = [Bool] -- [] No info -- @@ -1439,8 +1449,8 @@ mkAltEnv env scrut cb where pe = occ_proxy env pe' = case scrut of - Var v -> extendProxyEnv pe v IdCo cb - Cast (Var v) co -> extendProxyEnv pe v (ACo co) cb + Var v -> extendProxyEnv pe v (IdCo (idType v)) cb + Cast (Var v) co -> extendProxyEnv pe v (ACo co) cb _other -> trimProxyEnv pe [cb] ----------- @@ -1466,7 +1476,7 @@ trimProxyEnv (PE pe fvs) bndrs ----------- freeVarsCoI :: CoercionI -> VarSet -freeVarsCoI IdCo = emptyVarSet +freeVarsCoI (IdCo t) = tyVarsOfType t freeVarsCoI (ACo co) = tyVarsOfType co \end{code} @@ -1499,9 +1509,8 @@ addOneOcc usage id info emptyDetails :: UsageDetails emptyDetails = (emptyVarEnv :: UsageDetails) -localUsedIn, usedIn :: Id -> UsageDetails -> Bool -v `localUsedIn` details = v `elemVarEnv` details -v `usedIn` details = isExportedId v || v `localUsedIn` details +usedIn :: Id -> UsageDetails -> Bool +v `usedIn` details = isExportedId v || v `elemVarEnv` details type IdWithOccInfo = Id @@ -1535,7 +1544,7 @@ tagBinder usage binder setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr setBinderOcc usage bndr - | isTyVar bndr = bndr + | isTyCoVar bndr = bndr | isExportedId bndr = case idOccInfo bndr of NoOccInfo -> bndr _ -> setIdOccInfo bndr NoOccInfo