X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSetLevels.lhs;h=c684e7d4113726b4a13c669f4b70be5f3d97752a;hb=fb9d21af24d076b12abb9e22251aa327f82e8ea8;hp=d0914c948bfd68c97e57096f04e43729dd5e793c;hpb=b84ba676034763b3082bbd9405794a4fde499d14;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index d0914c9..c684e7d 100644
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -54,18 +54,13 @@ module SetLevels (
 #include "HsVersions.h"
 
 import CoreSyn
-
-import DynFlags		( FloatOutSwitches(..) )
+import CoreMonad	( FloatOutSwitches(..) )
 import CoreUtils	( exprType, mkPiTypes )
 import CoreArity	( exprBotStrictness_maybe )
 import CoreFVs		-- all of it
 import CoreSubst	( Subst, emptySubst, extendInScope, extendInScopeList,
 			  extendIdSubst, cloneIdBndr, cloneRecIdBndrs )
-import Id		( idType, mkLocalIdWithInfo, mkSysLocal, isOneShotLambda,
-			  zapDemandIdInfo, transferPolyIdInfo,
-			  idSpecialisation, idUnfolding, setIdInfo, 
-			  setIdStrictness, setIdArity
-			)
+import Id
 import IdInfo
 import Var
 import VarSet
@@ -251,10 +246,42 @@ lvlExpr _ _ (  _, AnnType ty) = return (Type ty)
 lvlExpr _ env (_, AnnVar v)   = return (lookupVar env v)
 lvlExpr _ _   (_, AnnLit lit) = return (Lit lit)
 
-lvlExpr ctxt_lvl env (_, AnnApp fun arg) = do
-    fun' <- lvlExpr ctxt_lvl env fun   -- We don't do MFE on partial applications
-    arg' <- lvlMFE  False ctxt_lvl env arg
-    return (App fun' arg')
+lvlExpr ctxt_lvl env expr@(_, AnnApp _ _) = do
+    let
+      (fun, args) = collectAnnArgs expr
+    --
+    case fun of
+         -- float out partial applications.  This is very beneficial
+         -- in some cases (-7% runtime -4% alloc over nofib -O2).
+         -- In order to float a PAP, there must be a function at the
+         -- head of the application, and the application must be
+         -- over-saturated with respect to the function's arity.
+      (_, AnnVar f) | floatPAPs env &&
+                      arity > 0 && arity < n_val_args ->
+        do
+         let (lapp, rargs) = left (n_val_args - arity) expr []
+         rargs' <- mapM (lvlMFE False ctxt_lvl env) rargs
+         lapp' <- lvlMFE False ctxt_lvl env lapp
+         return (foldl App lapp' rargs')
+        where
+         n_val_args = count (isValArg . deAnnotate) args
+         arity = idArity f
+
+         -- separate out the PAP that we are floating from the extra
+         -- arguments, by traversing the spine until we have collected
+         -- (n_val_args - arity) value arguments.
+         left 0 e               rargs = (e, rargs)
+         left n (_, AnnApp f a) rargs
+            | isValArg (deAnnotate a) = left (n-1) f (a:rargs)
+            | otherwise               = left n     f (a:rargs)
+         left _ _ _                   = panic "SetLevels.lvlExpr.left"
+
+         -- No PAPs that we can float: just carry on with the
+         -- arguments and the function.
+      _otherwise -> do
+         args' <- mapM (lvlMFE False ctxt_lvl env) args
+         fun'  <- lvlExpr ctxt_lvl env fun
+         return (foldl App fun' args')
 
 lvlExpr ctxt_lvl env (_, AnnNote note expr) = do
     expr' <- lvlExpr ctxt_lvl env expr
@@ -450,7 +477,7 @@ notWorthFloating :: CoreExprWithFVs -> [Var] -> Bool
 --   abs_vars = tvars only:  return True if e is trivial, 
 --                           but False for anything bigger
 --   abs_vars = [x] (an Id): return True for trivial, or an application (f x)
---   	      	    	     but False for (f x x) 
+--   	      	    	     but False for (f x x)
 --
 -- One big goal is that floating should be idempotent.  Eg if
 -- we replace e with (lvl79 x y) and then run FloatOut again, don't want
@@ -459,8 +486,8 @@ notWorthFloating :: CoreExprWithFVs -> [Var] -> Bool
 notWorthFloating e abs_vars
   = go e (count isId abs_vars)
   where
-    go (_, AnnVar {}) n    = n == 0
-    go (_, AnnLit {}) n    = n == 0
+    go (_, AnnVar {}) n    = n >= 0
+    go (_, AnnLit {}) n    = n >= 0
     go (_, AnnCast e _)  n = go e n
     go (_, AnnApp e arg) n 
        | (_, AnnType {}) <- arg = go e n
@@ -536,7 +563,7 @@ lvlBind :: TopLevelFlag		-- Used solely to decide whether to clone
 	-> LvlM (LevelledBind, LevelEnv)
 
 lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
-  |  isTyVar bndr 		-- Don't do anything for TyVar binders
+  |  isTyCoVar bndr 		-- Don't do anything for TyVar binders
 				--   (simplifier gets rid of them pronto)
   = do rhs' <- lvlExpr ctxt_lvl env rhs
        return (NonRec (TB bndr ctxt_lvl) rhs', env)
@@ -616,7 +643,7 @@ lvlBind top_lvl ctxt_lvl env (AnnRec pairs)
     abs_vars = abstractVars dest_lvl env bind_fvs
 
 ----------------------------------------------------
--- Three help functons for the type-abstraction case
+-- Three help functions for the type-abstraction case
 
 lvlFloatRhs :: [CoreBndr] -> Level -> LevelEnv -> CoreExprWithFVs
             -> UniqSM (Expr (TaggedBndr Level))
@@ -644,26 +671,15 @@ lvlLamBndrs lvl []
   = (lvl, [])
 
 lvlLamBndrs lvl bndrs
-  = go  (incMinorLvl lvl)
-	False 	-- Havn't bumped major level in this group
-	[] bndrs
+  = (new_lvl, [TB bndr new_lvl | bndr <- bndrs])
+  -- All the new binders get the same level, because
+  -- any floating binding is either going to float past 
+  -- all or none.  We never separate binders
   where
-    go old_lvl bumped_major rev_lvld_bndrs (bndr:bndrs)
-	| isId bndr &&	    		-- Go to the next major level if this is a value binder,
-	  not bumped_major && 		-- and we havn't already gone to the next level (one jump per group)
-	  not (isOneShotLambda bndr)	-- and it isn't a one-shot lambda
-	= go new_lvl True (TB bndr new_lvl : rev_lvld_bndrs) bndrs
-
-	| otherwise
-	= go old_lvl bumped_major (TB bndr old_lvl : rev_lvld_bndrs) bndrs
+    new_lvl | any is_major bndrs = incMajorLvl lvl
+            | otherwise          = incMinorLvl lvl
 
-	where
-	  new_lvl = incMajorLvl old_lvl
-
-    go old_lvl _ rev_lvld_bndrs []
-	= (old_lvl, reverse rev_lvld_bndrs)
-	-- a lambda like this (\x -> coerce t (\s -> ...))
-	-- This happens quite a bit in state-transformer programs
+    is_major bndr = isId bndr && not (isOneShotLambda bndr)
 \end{code}
 
 \begin{code}
@@ -742,6 +758,9 @@ floatLams (fos, _, _, _) = floatOutLambdas fos
 floatConsts :: LevelEnv -> Bool
 floatConsts (fos, _, _, _) = floatOutConstants fos
 
+floatPAPs :: LevelEnv -> Bool
+floatPAPs (fos, _, _, _) = floatOutPartialApplications fos
+
 extendLvlEnv :: LevelEnv -> [TaggedBndr Level] -> LevelEnv
 -- Used when *not* cloning
 extendLvlEnv (float_lams, lvl_env, subst, id_env) prs
@@ -846,7 +865,7 @@ abstractVars dest_lvl (_, lvl_env, _, id_env) fvs
 		   (False, True) -> False
 		   _    	 -> v1 <= v2	-- Same family
 
-    is_tv v = isTyVar v && not (isCoVar v)
+    is_tv v = isTyCoVar v && not (isCoVar v)
 
     uniq :: [Var] -> [Var]
 	-- Remove adjacent duplicates; the sort will have brought them together
@@ -860,7 +879,7 @@ abstractVars dest_lvl (_, lvl_env, _, id_env) fvs
 
 	-- We are going to lambda-abstract, so nuke any IdInfo,
 	-- and add the tyvars of the Id (if necessary)
-    zap v | isId v = WARN( isInlineRule (idUnfolding v) ||
+    zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||
 		           not (isEmptySpecInfo (idSpecialisation v)),
 		           text "absVarsOf: discarding info on" <+> ppr v )
 		     setIdInfo v vanillaIdInfo