X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FcoreSyn%2FCoreTidy.lhs;h=c985f95abc136e3de00619f64d27a88c2661ba78;hb=8a412ad430be3513ea2385123979d5ef505a4f77;hp=3407734608dc1c50571b6866a246f38664224bf4;hpb=d364541154457a49e3c35d671d7a1b57c9c4cca3;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 3407734..c985f95 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -21,36 +21,32 @@ import VarEnv import VarSet import Var ( Id, Var ) import Id ( idType, idInfo, idName, isExportedId, - mkId, isLocalId, omitIfaceSigForId + idCafInfo, mkId, isLocalId, isImplicitId, + idFlavour, modifyIdInfo, idArity ) -import IdInfo ( IdInfo, mkIdInfo, vanillaIdInfo, - IdFlavour(..), flavourInfo, ppFlavourInfo, - specInfo, setSpecInfo, - cprInfo, setCprInfo, - inlinePragInfo, setInlinePragInfo, isNeverInlinePrag, - strictnessInfo, setStrictnessInfo, - isBottomingStrictness, - unfoldingInfo, setUnfoldingInfo, - occInfo, isLoopBreaker, - workerInfo, setWorkerInfo, WorkerInfo(..), - ArityInfo(..), setArityInfo - ) +import IdInfo {- loads of stuff -} import Name ( getOccName, nameOccName, globaliseName, setNameOcc, - localiseName, mkLocalName, isGlobalName + localiseName, mkLocalName, isGlobalName, isDllName ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) import Type ( tidyTopType, tidyType, tidyTyVar ) import Module ( Module, moduleName ) -import HscTypes ( PersistentCompilerState( pcs_PRS ), PersistentRenamerState( prsOrig ), - OrigNameEnv( origNames ), OrigNameNameEnv +import PrimOp ( PrimOp(..), setCCallUnique ) +import HscTypes ( PersistentCompilerState( pcs_PRS ), + PersistentRenamerState( prsOrig ), + NameSupply( nsNames ), OrigNameCache ) import UniqSupply +import DataCon ( DataCon, dataConName ) +import Literal ( isLitLitLit ) import FiniteMap ( lookupFM, addToFM ) import Maybes ( maybeToBool, orElse ) import ErrUtils ( showPass ) +import PprCore ( pprIdCoreRule ) import SrcLoc ( noSrcLoc ) import UniqFM ( mapUFM ) import Outputable +import FastTypes import List ( partition ) import Util ( mapAccumL ) \end{code} @@ -101,10 +97,19 @@ binder that all Ids are unique, rather than the weaker guarantee of no clashes which the simplifier provides. - - Give the Id its final IdInfo; in ptic, + - Give each dynamic CCall occurrence a fresh unique; this is + rather like the cloning step above. + + - Give the Id its UTTERLY FINAL IdInfo; in ptic, * Its flavour becomes ConstantId, reflecting the fact that from now on we regard it as a constant, not local, Id + * its unfolding, if it should have one + + * its arity, computed from the number of visible lambdas + + * its CAF info, computed from what is free in its RHS + Finally, substitute these new top-level binders consistently throughout, including in unfoldings. We also tidy binders in @@ -126,10 +131,10 @@ tidyCorePgm dflags mod pcs binds_in orphans_in = mapAccumL (tidyTopBind mod ext_ids) (init_tidy_env us) binds_in - ; let (orphans_out, us2) + ; let (orphans_out, _) = initUs us1 (tidyIdRules (occ_env,subst_env) orphans_in) - ; let prs' = prs { prsOrig = orig { origNames = orig_env' } } + ; let prs' = prs { prsOrig = orig { nsNames = orig_env' } } pcs' = pcs { pcs_PRS = prs' } ; endPass dflags "Tidy Core" Opt_D_dump_simpl binds_out @@ -147,7 +152,7 @@ tidyCorePgm dflags mod pcs binds_in orphans_in -- decl. tidyTopId then does a no-op on exported binders. prs = pcs_PRS pcs orig = prsOrig prs - orig_env = origNames orig + orig_env = nsNames orig init_tidy_env us = (us, orig_env, initTidyOccEnv avoids, emptyVarEnv) avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in, @@ -166,7 +171,8 @@ findExternalSet :: [CoreBind] -> [IdCoreRule] -> IdEnv Bool -- True <=> show unfolding -- Step 1 from the notes above findExternalSet binds orphan_rules - = foldr find init_needed binds + = pprTrace "fes" (vcat (map pprIdCoreRule orphan_rules) $$ ppr (varSetElems orphan_rule_ids)) $ + foldr find init_needed binds where orphan_rule_ids :: IdSet orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isIdAndLocal rule @@ -255,7 +261,7 @@ addExternal (id,rhs) needed \begin{code} -type TopTidyEnv = (UniqSupply, OrigNameNameEnv, TidyOccEnv, VarEnv Var) +type TopTidyEnv = (UniqSupply, OrigNameCache, TidyOccEnv, VarEnv Var) -- TopTidyEnv: when tidying we need to know -- * orig_env: Any pre-ordained Names. These may have arisen because the @@ -285,37 +291,44 @@ tidyTopBind :: Module tidyTopBind mod ext_ids env (NonRec bndr rhs) = ((us2,orig,occ,subst) , NonRec bndr' rhs') where - (env1@(us1,orig,occ,subst), bndr') = tidyTopBinder mod ext_ids env rhs' env bndr - (rhs',us2) = initUs us1 (tidyTopRhs env1 rhs) + ((us1,orig,occ,subst), bndr') + = tidyTopBinder mod ext_ids tidy_env rhs' caf_info env bndr + tidy_env = (occ,subst) + caf_info = hasCafRefs (const True) rhs' + (rhs',us2) = initUs us1 (tidyExpr tidy_env rhs) tidyTopBind mod ext_ids env (Rec prs) = (final_env, Rec prs') where - (final_env, prs') = mapAccumL do_one env prs + (final_env@(_,_,occ,subst), prs') = mapAccumL do_one env prs + final_tidy_env = (occ,subst) do_one env (bndr,rhs) = ((us',orig,occ,subst), (bndr',rhs')) where - (env'@(us,orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids final_env rhs' env bndr - (rhs', us') = initUs us (tidyTopRhs final_env rhs) - + ((us,orig,occ,subst), bndr') + = tidyTopBinder mod ext_ids final_tidy_env rhs' caf_info env bndr + (rhs', us') = initUs us (tidyExpr final_tidy_env rhs) -tidyTopRhs :: TopTidyEnv -> CoreExpr -> UniqSM CoreExpr - -- Just an impedence matcher -tidyTopRhs (_, _, occ_env, subst_env) rhs - = tidyExpr (occ_env, subst_env) rhs + -- the CafInfo for a recursive group says whether *any* rhs in + -- the group may refer indirectly to a CAF (because then, they all do). + (bndrs, rhss) = unzip prs' + caf_info = hasCafRefss pred rhss + pred v = v `notElem` bndrs tidyTopBinder :: Module -> IdEnv Bool - -> TopTidyEnv -> CoreExpr + -> TidyEnv -> CoreExpr -> CafInfo + -- The TidyEnv is used to tidy the IdInfo + -- The expr is the already-tided RHS + -- Both are knot-tied: don't look at them! -> TopTidyEnv -> Id -> (TopTidyEnv, Id) -tidyTopBinder mod ext_ids - final_env@(_, orig_env1, occ_env1, subst_env1) rhs + +tidyTopBinder mod ext_ids tidy_env rhs caf_info env@(us, orig_env2, occ_env2, subst_env2) id - | omitIfaceSigForId id -- Don't mess with constructors, - = (env, id) -- record selectors, and the like + | isImplicitId id -- Don't mess with constructors, + = (env, id) -- record selectors, and the like | otherwise -- This function is the heart of Step 2 @@ -334,8 +347,8 @@ tidyTopBinder mod ext_ids is_external (idName id) ty' = tidyTopType (idType id) - idinfo' = tidyIdInfo us_l (occ_env1, subst_env1) - is_external unfold_info arity_info id + idinfo' = tidyIdInfo us_l tidy_env + is_external unfold_info arity_info caf_info id id' = mkId name' ty' idinfo' subst_env' = extendVarEnv subst_env2 id id' @@ -351,23 +364,23 @@ tidyTopBinder mod ext_ids arity_info = exprArity rhs -tidyIdInfo us tidy_env is_external unfold_info arity_info id +tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id | opt_OmitInterfacePragmas || not is_external -- No IdInfo if the Id isn't external, or if we don't have -O - = mkIdInfo new_flavour + = mkIdInfo new_flavour caf_info `setStrictnessInfo` strictnessInfo core_idinfo `setArityInfo` ArityExactly arity_info - -- Keep strictness and arity info; it's used by the code generator + -- Keep strictness, arity and CAF info; it's used by the code generator | otherwise - = let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo)) + = let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo)) in - mkIdInfo new_flavour + mkIdInfo new_flavour caf_info `setCprInfo` cprInfo core_idinfo `setStrictnessInfo` strictnessInfo core_idinfo `setInlinePragInfo` inlinePragInfo core_idinfo `setUnfoldingInfo` unfold_info - `setWorkerInfo` tidyWorker tidy_env (workerInfo core_idinfo) + `setWorkerInfo` tidyWorker tidy_env arity_info (workerInfo core_idinfo) `setSpecInfo` rules' `setArityInfo` ArityExactly arity_info -- this is the final IdInfo, it must agree with the @@ -386,28 +399,30 @@ tidyIdInfo us tidy_env is_external unfold_info arity_info id flavour -> pprTrace "tidyIdInfo" (ppr id <+> ppFlavourInfo flavour) flavour --- this is where we set names to local/global based on whether they really are + +-- This is where we set names to local/global based on whether they really are -- externally visible (see comment at the top of this module). If the name -- was previously local, we have to give it a unique occurrence name if -- we intend to globalise it. tidyTopName mod orig_env occ_env external name | global && internal = (orig_env, occ_env, localiseName name) - | local && internal = (orig_env, occ_env', setNameOcc name occ') -- (*) + + | local && internal = (orig_env, occ_env', setNameOcc name occ') + -- Even local, internal names must get a unique occurrence, because + -- if we do -split-objs we globalise the name later, n the code generator + | global && external = (orig_env, occ_env, name) - | local && external = globalise - -- (*) just in case we're globalising all top-level names (because of - -- -split-objs), we need to give *all* the top-level ids a - -- unique occurrence name. The actual globalisation now happens in the code - -- generator. - where + -- Global names are assumed to have been allocated by the renamer, + -- so they already have the "right" unique + + | local && external = case lookupFM orig_env key of + Just orig -> (orig_env, occ_env', orig) + Nothing -> (addToFM orig_env key global_name, occ_env', global_name) -- If we want to globalise a currently-local name, check -- whether we have already assigned a unique for it. -- If so, use it; if not, extend the table - globalise - = case lookupFM orig_env key of - Just orig -> (orig_env, occ_env', orig) - Nothing -> (addToFM orig_env key global_name, occ_env', global_name) + where (occ_env', occ') = tidyOccName occ_env (nameOccName name) key = (moduleName mod, occ') global_name = globaliseName (setNameOcc name occ') mod @@ -415,6 +430,35 @@ tidyTopName mod orig_env occ_env external name local = not global internal = not external +------------ Worker -------------- +-- We only treat a function as having a worker if +-- the exported arity (which is now the number of visible lambdas) +-- is the same as the arity at the moment of the w/w split +-- If so, we can safely omit the unfolding inside the wrapper, and +-- instead re-generate it from the type/arity/strictness info +-- But if the arity has changed, we just take the simple path and +-- put the unfolding into the interface file, forgetting the fact +-- that it's a wrapper. +-- +-- How can this happen? Sometimes we get +-- f = coerce t (\x y -> $wf x y) +-- at the moment of w/w split; but the eta reducer turns it into +-- f = coerce t $wf +-- which is perfectly fine except that the exposed arity so far as +-- the code generator is concerned (zero) differs from the arity +-- when we did the split (2). +-- +-- All this arises because we use 'arity' to mean "exactly how many +-- top level lambdas are there" in interface files; but during the +-- compilation of this module it means "how many things can I apply +-- this to". +tidyWorker tidy_env real_arity (HasWorker work_id wrap_arity) + | real_arity == wrap_arity + = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity +tidyWorker tidy_env real_arity other + = NoWorker + +------------ Rules -------------- tidyIdRules :: TidyEnv -> [IdCoreRule] -> UniqSM [IdCoreRule] tidyIdRules env [] = returnUs [] tidyIdRules env ((fn,rule) : rules) @@ -422,11 +466,6 @@ tidyIdRules env ((fn,rule) : rules) tidyIdRules env rules `thenUs` \ rules -> returnUs ((tidyVarOcc env fn, rule) : rules) -tidyWorker tidy_env (HasWorker work_id wrap_arity) - = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity -tidyWorker tidy_env NoWorker - = NoWorker - tidyRules :: TidyEnv -> CoreRules -> UniqSM CoreRules tidyRules env (Rules rules fvs) = mapUs (tidyRule env) rules `thenUs` \ rules -> @@ -463,7 +502,10 @@ tidyBind env (Rec prs) mapUs (tidyExpr env') (map snd prs) `thenUs` \ rhss' -> returnUs (env', Rec (zip bndrs' rhss')) -tidyExpr env (Var v) = returnUs (Var (tidyVarOcc env v)) +tidyExpr env (Var v) + = fiddleCCall v `thenUs` \ v -> + returnUs (Var (tidyVarOcc env v)) + tidyExpr env (Type ty) = returnUs (Type (tidyType env ty)) tidyExpr env (Lit lit) = returnUs (Lit lit) @@ -548,4 +590,133 @@ tidyId env@(tidy_env, var_env) id idinfo var_env' = extendVarEnv var_env id id' in returnUs ((tidy_env', var_env'), id') + + +fiddleCCall id + = case idFlavour id of + PrimOpId (CCallOp ccall) -> + -- Make a guaranteed unique name for a dynamic ccall. + getUniqueUs `thenUs` \ uniq -> + returnUs (modifyIdInfo (`setFlavourInfo` + PrimOpId (CCallOp (setCCallUnique ccall uniq))) id) + other_flavour -> + returnUs id +\end{code} + +%************************************************************************ +%* * +\subsection{Figuring out CafInfo for an expression} +%* * +%************************************************************************ + +hasCafRefs decides whether a top-level closure can point into the dynamic heap. +We mark such things as `MayHaveCafRefs' because this information is +used to decide whether a particular closure needs to be referenced +in an SRT or not. + +There are two reasons for setting MayHaveCafRefs: + a) The RHS is a CAF: a top-level updatable thunk. + b) The RHS refers to something that MayHaveCafRefs + +Possible improvement: In an effort to keep the number of CAFs (and +hence the size of the SRTs) down, we could also look at the expression and +decide whether it requires a small bounded amount of heap, so we can ignore +it as a CAF. In these cases however, we would need to use an additional +CAF list to keep track of non-collectable CAFs. + +\begin{code} +hasCafRefs :: (Id -> Bool) -> CoreExpr -> CafInfo +-- Only called for the RHS of top-level lets +hasCafRefss :: (Id -> Bool) -> [CoreExpr] -> CafInfo + -- predicate returns True for a given Id if we look at this Id when + -- calculating the result. Used to *avoid* looking at the CafInfo + -- field for an Id that is part of the current recursive group. + +hasCafRefs p expr = if isCAF expr || isFastTrue (cafRefs p expr) + then MayHaveCafRefs + else NoCafRefs + + -- used for recursive groups. The whole group is set to + -- "MayHaveCafRefs" if at least one of the group is a CAF or + -- refers to any CAFs. +hasCafRefss p exprs = if any isCAF exprs || isFastTrue (cafRefss p exprs) + then MayHaveCafRefs + else NoCafRefs + +cafRefs p (Var id) + | p id + = case idCafInfo id of + NoCafRefs -> fastBool False + MayHaveCafRefs -> fastBool True + | otherwise + = fastBool False + +cafRefs p (Lit l) = fastBool False +cafRefs p (App f a) = cafRefs p f `fastOr` cafRefs p a +cafRefs p (Lam x e) = cafRefs p e +cafRefs p (Let b e) = cafRefss p (rhssOfBind b) `fastOr` cafRefs p e +cafRefs p (Case e bndr alts) = cafRefs p e `fastOr` cafRefss p (rhssOfAlts alts) +cafRefs p (Note n e) = cafRefs p e +cafRefs p (Type t) = fastBool False + +cafRefss p [] = fastBool False +cafRefss p (e:es) = cafRefs p e `fastOr` cafRefss p es + + +isCAF :: CoreExpr -> Bool +-- Only called for the RHS of top-level lets +isCAF e = not (rhsIsNonUpd e) + {- ToDo: check type for onceness, i.e. non-updatable thunks? -} + +rhsIsNonUpd :: CoreExpr -> Bool + -- True => Value-lambda, constructor, PAP + -- This is a bit like CoreUtils.exprIsValue, with the following differences: + -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) + -- + -- b) (C x xs), where C is a contructors is updatable if the application is + -- dynamic: see isDynConApp + -- + -- c) don't look through unfolding of f in (f x). I'm suspicious of this one + +rhsIsNonUpd (Lam b e) = isId b || rhsIsNonUpd e +rhsIsNonUpd (Note (SCC _) e) = False +rhsIsNonUpd (Note _ e) = rhsIsNonUpd e +rhsIsNonUpd other_expr + = go other_expr 0 [] + where + go (Var f) n_args args = idAppIsNonUpd f n_args args + + go (App f a) n_args args + | isTypeArg a = go f n_args args + | otherwise = go f (n_args + 1) (a:args) + + go (Note (SCC _) f) n_args args = False + go (Note _ f) n_args args = go f n_args args + + go other n_args args = False + +idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool +idAppIsNonUpd id n_val_args args + = case idFlavour id of + DataConId con | not (isDynConApp con args) -> True + other -> n_val_args < idArity id + +isDynConApp :: DataCon -> [CoreExpr] -> Bool +isDynConApp con args = isDllName (dataConName con) || any isDynArg args +-- Top-level constructor applications can usually be allocated +-- statically, but they can't if +-- a) the constructor, or any of the arguments, come from another DLL +-- b) any of the arguments are LitLits +-- (because we can't refer to static labels in other DLLs). +-- If this happens we simply make the RHS into an updatable thunk, +-- and 'exectute' it rather than allocating it statically. +-- All this should match the decision in (see CoreToStg.coreToStgRhs) + + +isDynArg :: CoreExpr -> Bool +isDynArg (Var v) = isDllName (idName v) +isDynArg (Note _ e) = isDynArg e +isDynArg (Lit lit) = isLitLitLit lit +isDynArg (App e _) = isDynArg e -- must be a type app +isDynArg (Lam _ e) = isDynArg e -- must be a type lam \end{code}