X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSetLevels.lhs;h=9726aa68a0d2b44b9ae231a380297536877b1ee1;hb=21ca8c314073342107ee7e2ea2e700781039d2a5;hp=4b4a3498aa83bbb20e5a4cdb41d5c38b38c0b89a;hpb=eced5e4068f4cb5da397ca1fd4eeea462f197503;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index 4b4a349..9726aa6 100644
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -358,13 +358,22 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr ty alts) = do
 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
 the expression, so that it can itself be floated.
 
-[NOTE: unlifted MFEs]
+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.
 
+Note [Case MFEs]
+~~~~~~~~~~~~~~~~
+We don't float a case expression as an MFE from a strict context.  Why not?
+Because in doing so we share a tiny bit of computation (the switch) but
+in exchange we build a thunk, which is bad.  This case reduces allocation 
+by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.
+Doesn't change any other allocation at all.
+
 \begin{code}
 lvlMFE ::  Bool			-- True <=> strict context [body of case or let]
 	-> Level		-- Level of innermost enclosing lambda/tylam
@@ -375,9 +384,20 @@ lvlMFE ::  Bool			-- True <=> strict context [body of case or let]
 lvlMFE _ _ _ (_, AnnType ty)
   = return (Type ty)
 
+-- No point in floating out an expression wrapped in a coercion;
+-- If we do we'll transform  lvl = e |> co 
+--			 to  lvl' = e; lvl = lvl' |> co
+-- and then inline lvl.  Better just to float out the payload.
+lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e co)
+  = do	{ expr' <- lvlMFE strict_ctxt ctxt_lvl env e
+	; return (Cast expr' co) }
+
+-- Note [Case MFEs]
+lvlMFE True ctxt_lvl env e@(_, AnnCase {})
+  = lvlExpr ctxt_lvl env e     -- Don't share cases
 
 lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
-  |  isUnLiftedType ty			-- Can't let-bind it; see [NOTE: unlifted MFEs]
+  |  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
@@ -481,7 +501,9 @@ 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
+  |  isTyVar bndr 		-- Don't do anything for TyVar binders
+				--   (simplifier gets rid of them pronto)
+  || isInlineCtxt ctxt_lvl	-- Don't do anything inside InlineMe
   = do rhs' <- lvlExpr ctxt_lvl env rhs
        return (NonRec (TB bndr ctxt_lvl) rhs', env)
 
@@ -595,7 +617,7 @@ lvlLamBndrs lvl bndrs
 	[] bndrs
   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,
+	| 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
@@ -681,10 +703,10 @@ initialEnv :: FloatOutSwitches -> LevelEnv
 initialEnv float_lams = (float_lams, emptyVarEnv, emptySubst, emptyVarEnv)
 
 floatLams :: LevelEnv -> Bool
-floatLams (FloatOutSw float_lams _, _, _, _) = float_lams
+floatLams (fos, _, _, _) = floatOutLambdas fos
 
 floatConsts :: LevelEnv -> Bool
-floatConsts (FloatOutSw _ float_consts, _, _, _) = float_consts
+floatConsts (fos, _, _, _) = floatOutConstants fos
 
 extendLvlEnv :: LevelEnv -> [TaggedBndr Level] -> LevelEnv
 -- Used when *not* cloning
@@ -841,7 +863,7 @@ newPolyBndrs dest_lvl env abs_vars bndrs = do
     let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
     return (extendPolyLvlEnv dest_lvl env abs_vars (bndrs `zip` new_bndrs), new_bndrs)
   where
-    mk_poly_bndr bndr uniq = transferPolyIdInfo bndr $ 	-- Note [transferPolyIdInfo] in Id.lhs
+    mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ 	-- Note [transferPolyIdInfo] in Id.lhs
 			     mkSysLocal (mkFastString str) uniq poly_ty
 			   where
 			     str     = "poly_" ++ occNameString (getOccName bndr)