X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSetLevels.lhs;h=f8ab29dcd593189f77eb18929143305d51ae4b5a;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=647e22c2303bf219e98d2c9bf6962b67ad34281d;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 647e22c..f8ab29d 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -55,24 +55,25 @@ module SetLevels ( import CoreSyn -import CmdLineOpts ( FloatOutSwitches(..) ) +import DynFlags ( FloatOutSwitches(..) ) import CoreUtils ( exprType, exprIsTrivial, exprIsCheap, mkPiTypes ) import CoreFVs -- all of it -import Subst -import Id ( Id, idType, mkSysLocalUnencoded, - isOneShotLambda, zapDemandIdInfo, +import CoreSubst ( Subst, emptySubst, extendInScope, extendIdSubst, + cloneIdBndr, cloneRecIdBndrs ) +import Id ( Id, idType, mkSysLocal, isOneShotLambda, + zapDemandIdInfo, idSpecialisation, idWorkerInfo, setIdInfo ) -import IdInfo ( workerExists, vanillaIdInfo, ) +import IdInfo ( workerExists, vanillaIdInfo, isEmptySpecInfo ) import Var ( Var ) import VarSet import VarEnv import Name ( getOccName ) -import OccName ( occNameUserString ) +import OccName ( occNameString ) import Type ( isUnLiftedType, Type ) import BasicTypes ( TopLevelFlag(..) ) import UniqSupply -import Util ( sortLt, isSingleton, count ) +import Util ( sortLe, isSingleton, count ) import Outputable import FastString \end{code} @@ -274,7 +275,8 @@ lvlExpr ctxt_lvl env (_, AnnApp fun arg) lvlMFE False ctxt_lvl env arg `thenLvl` \ arg' -> returnLvl (App fun' arg') where - lvl_fun (_, AnnCase _ _ _) = lvlMFE True ctxt_lvl env fun +-- gaw 2004 + lvl_fun (_, AnnCase _ _ _ _) = lvlMFE True ctxt_lvl env fun lvl_fun other = lvlExpr ctxt_lvl env fun -- We don't do MFE on partial applications generally, -- but we do if the function is big and hairy, like a case @@ -309,18 +311,35 @@ lvlExpr ctxt_lvl env expr@(_, AnnLam bndr rhs) -- but not nearly so much now non-recursive newtypes are transparent. -- [See SetLevels rev 1.50 for a version with this approach.] +lvlExpr ctxt_lvl env (_, AnnLet (AnnNonRec bndr rhs) body) + | isUnLiftedType (idType bndr) + -- Treat unlifted let-bindings (let x = b in e) just like (case b of x -> e) + -- That is, leave it exactly where it is + -- We used to float unlifted bindings too (e.g. to get a cheap primop + -- outside a lambda (to see how, look at lvlBind in rev 1.58) + -- but an unrelated change meant that these unlifed bindings + -- could get to the top level which is bad. And there's not much point; + -- unlifted bindings are always cheap, and so hardly worth floating. + = lvlExpr ctxt_lvl env rhs `thenLvl` \ rhs' -> + lvlExpr incd_lvl env' body `thenLvl` \ body' -> + returnLvl (Let (NonRec bndr' rhs') body') + where + incd_lvl = incMinorLvl ctxt_lvl + bndr' = TB bndr incd_lvl + env' = extendLvlEnv env [bndr'] + lvlExpr ctxt_lvl env (_, AnnLet bind body) = lvlBind NotTopLevel ctxt_lvl env bind `thenLvl` \ (bind', new_env) -> lvlExpr ctxt_lvl new_env body `thenLvl` \ body' -> returnLvl (Let bind' body') -lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts) +lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr ty alts) = lvlMFE True ctxt_lvl env expr `thenLvl` \ expr' -> let alts_env = extendCaseBndrLvlEnv env expr' case_bndr incd_lvl in mapLvl (lvl_alt alts_env) alts `thenLvl` \ alts' -> - returnLvl (Case expr' (TB case_bndr incd_lvl) alts') + returnLvl (Case expr' (TB case_bndr incd_lvl) ty alts') where incd_lvl = incMinorLvl ctxt_lvl @@ -335,6 +354,13 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts) @lvlMFE@ is just like @lvlExpr@, except that it might let-bind the expression, so that it can itself be floated. +[NOTE: unlifted MFEs] +We don't float unlifted MFEs, which potentially loses big opportunites. +For example: + \x -> f (h y) +where h :: Int -> Int# is expensive. We'd like to float the (h y) outside +the \x, but we don't because it's unboxed. Possible solution: box it. + \begin{code} lvlMFE :: Bool -- True <=> strict context [body of case or let] -> Level -- Level of innermost enclosing lambda/tylam @@ -345,8 +371,9 @@ lvlMFE :: Bool -- True <=> strict context [body of case or let] lvlMFE strict_ctxt ctxt_lvl env (_, AnnType ty) = returnLvl (Type ty) + lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) - | isUnLiftedType ty -- Can't let-bind it + | isUnLiftedType ty -- Can't let-bind it; see [NOTE: unlifted MFEs] || isInlineCtxt ctxt_lvl -- Don't float out of an __inline__ context || exprIsTrivial expr -- Never float if it's trivial || not good_destination @@ -420,7 +447,7 @@ lvlBind :: TopLevelFlag -- Used solely to decide whether to clone -> LvlM (LevelledBind, LevelEnv) lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) - | isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe + | isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe = lvlExpr ctxt_lvl env rhs `thenLvl` \ rhs' -> returnLvl (NonRec (TB bndr ctxt_lvl) rhs', env) @@ -439,12 +466,7 @@ lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) where bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr abs_vars = abstractVars dest_lvl env bind_fvs - - dest_lvl | isUnLiftedType (idType bndr) = destLevel env bind_fvs False `maxLvl` Level 1 0 - | otherwise = destLevel env bind_fvs (isFunction rhs) - -- Hack alert! We do have some unlifted bindings, for cheap primops, and - -- it is ok to float them out; but not to the top level. If they would otherwise - -- go to the top level, we pin them inside the topmost lambda + dest_lvl = destLevel env bind_fvs (isFunction rhs) \end{code} @@ -660,7 +682,7 @@ extendLvlEnv (float_lams, lvl_env, subst, id_env) prs extendCaseBndrLvlEnv (float_lams, lvl_env, subst, id_env) (Var scrut_var) case_bndr lvl = (float_lams, extendVarEnv lvl_env case_bndr lvl, - extendSubst subst case_bndr (DoneEx (Var scrut_var)), + extendIdSubst subst case_bndr (Var scrut_var), extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var)) extendCaseBndrLvlEnv env scrut case_bndr lvl @@ -673,7 +695,7 @@ extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst, id_env) abs_vars bndr_pai foldl add_id id_env bndr_pairs) where add_lvl env (v,v') = extendVarEnv env v' dest_lvl - add_subst env (v,v') = extendSubst env v (DoneEx (mkVarApps (Var v') abs_vars)) + add_subst env (v,v') = extendIdSubst env v (mkVarApps (Var v') abs_vars) add_id env (v,v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) extendCloneLvlEnv lvl (float_lams, lvl_env, _, id_env) new_subst bndr_pairs @@ -710,14 +732,14 @@ abstractVars :: Level -> LevelEnv -> VarSet -> [Var] -- whose level is greater than the destination level -- These are the ones we are going to abstract out abstractVars dest_lvl env fvs - = uniq (sortLt lt [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv]) + = uniq (sortLe le [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv]) where -- Sort the variables so we don't get -- mixed-up tyvars and Ids; it's just messy - v1 `lt` v2 = case (isId v1, isId v2) of + v1 `le` v2 = case (isId v1, isId v2) of (True, False) -> False (False, True) -> True - other -> v1 < v2 -- Same family + other -> v1 <= v2 -- Same family uniq :: [Var] -> [Var] -- Remove adjacent duplicates; the sort will have brought them together @@ -751,7 +773,7 @@ absVarsOf dest_lvl (_, lvl_env, _, id_env) v -- We are going to lambda-abstract, so nuke any IdInfo, -- and add the tyvars of the Id (if necessary) zap v | isId v = WARN( workerExists (idWorkerInfo v) || - not (isEmptyCoreRules (idSpecialisation v)), + not (isEmptySpecInfo (idSpecialisation v)), text "absVarsOf: discarding info on" <+> ppr v ) setIdInfo v vanillaIdInfo | otherwise = v @@ -774,9 +796,9 @@ newPolyBndrs dest_lvl env abs_vars bndrs in returnLvl (extendPolyLvlEnv dest_lvl env abs_vars (bndrs `zip` new_bndrs), new_bndrs) where - mk_poly_bndr bndr uniq = mkSysLocalUnencoded (mkFastString str) uniq poly_ty + mk_poly_bndr bndr uniq = mkSysLocal (mkFastString str) uniq poly_ty where - str = "poly_" ++ occNameUserString (getOccName bndr) + str = "poly_" ++ occNameString (getOccName bndr) poly_ty = mkPiTypes abs_vars (idType bndr) @@ -785,7 +807,7 @@ newLvlVar :: String -> LvlM Id newLvlVar str vars body_ty = getUniqueUs `thenLvl` \ uniq -> - returnUs (mkSysLocalUnencoded (mkFastString str) uniq (mkPiTypes vars body_ty)) + returnUs (mkSysLocal (mkFastString str) uniq (mkPiTypes vars body_ty)) -- The deeply tiresome thing is that we have to apply the substitution -- to the rules inside each Id. Grr. But it matters. @@ -797,7 +819,7 @@ cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl = ASSERT( isId v ) getUs `thenLvl` \ us -> let - (subst', v1) = substAndCloneId subst us v + (subst', v1) = cloneIdBndr subst us v v2 = zap_demand ctxt_lvl dest_lvl v1 env' = extendCloneLvlEnv dest_lvl env subst' [(v,v2)] in @@ -810,7 +832,7 @@ cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl = ASSERT( all isId vs ) getUs `thenLvl` \ us -> let - (subst', vs1) = substAndCloneRecIds subst us vs + (subst', vs1) = cloneRecIdBndrs subst us vs vs2 = map (zap_demand ctxt_lvl dest_lvl) vs1 env' = extendCloneLvlEnv dest_lvl env subst' (vs `zip` vs2) in