X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=c2128932150b992105119de922aed63979d97ca5;hp=0f6cf733a4697e104d4a620c11f814094d92be65;hb=4bc25e8c30559b7a6a87b39afcc79340ae778788;hpb=e79c9ce01d0ce4412bd4bcd99c8c728a6a2ec569

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 0f6cf73..c212893 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -34,6 +34,7 @@ import qualified CoreSubst
 import PprCore
 import CoreFVs
 import CoreUtils
+import CoreArity	( etaExpand, exprEtaExpandArity )
 import CoreUnfold
 import Name
 import Id
@@ -230,8 +231,18 @@ splitInlineCont (ApplyTo dup (Type ty) se c)
   | Just (c1, c2) <- splitInlineCont c = Just (ApplyTo dup (Type ty) se c1, c2)
 splitInlineCont cont@(Stop {})         = Just (mkBoringStop, cont)
 splitInlineCont cont@(StrictBind {})   = Just (mkBoringStop, cont)
-splitInlineCont cont@(StrictArg  {})   = Just (mkBoringStop, cont)
 splitInlineCont _                      = Nothing
+	-- NB: we dissolve an InlineMe in any strict context, 
+	--     not just function aplication.  
+	-- E.g.  foldr k z (__inline_me (case x of p -> build ...))
+	--     Here we want to get rid of the __inline_me__ so we
+	--     can float the case, and see foldr/build
+	--
+	-- However *not* in a strict RHS, else we get
+	-- 	   let f = __inline_me__ (\x. e) in ...f...
+	-- Now if f is guaranteed to be called, hence a strict binding
+	-- we don't thereby want to dissolve the __inline_me__; for
+	-- example, 'f' might be a  wrapper, so we'd inline the worker
 \end{code}
 
 
@@ -359,7 +370,7 @@ mkArgInfo fun n_val_args call_cont
     vanilla_discounts, arg_discounts :: [Int]
     vanilla_discounts = repeat 0
     arg_discounts = case idUnfolding fun of
-			CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ discounts _ _)
+			CoreUnfolding _ _ _ _ _ (UnfoldIfGoodArgs _ discounts _ _)
 			      -> discounts ++ vanilla_discounts
 			_     -> vanilla_discounts
 
@@ -611,9 +622,9 @@ preInlineUnconditionally env top_lvl bndr rhs
   where
     phase = getMode env
     active = case phase of
-		   SimplGently    -> isAlwaysActive prag
-		   SimplPhase n _ -> isActive n prag
-    prag = idInlinePragma bndr
+		   SimplGently    -> isAlwaysActive act
+		   SimplPhase n _ -> isActive n act
+    act = idInlineActivation bndr
 
     try_once in_lam int_cxt	-- There's one textual occurrence
 	| not in_lam = isNotTopLevel top_lvl || early_phase
@@ -767,9 +778,9 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
 
   where
     active = case getMode env of
-		   SimplGently    -> isAlwaysActive prag
-		   SimplPhase n _ -> isActive n prag
-    prag = idInlinePragma bndr
+		   SimplGently    -> isAlwaysActive act
+		   SimplPhase n _ -> isActive n act
+    act = idInlineActivation bndr
 
 activeInline :: SimplEnv -> OutId -> Bool
 activeInline env id
@@ -790,9 +801,9 @@ activeInline env id
 	-- and they are now constructed as Compulsory unfoldings (in MkId)
 	-- so they'll happen anyway.
 
-      SimplPhase n _ -> isActive n prag
+      SimplPhase n _ -> isActive n act
   where
-    prag = idInlinePragma id
+    act = idInlineActivation id
 
 activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
 -- Nothing => No rules at all
@@ -818,14 +829,14 @@ activeRule dflags env
 %************************************************************************
 
 \begin{code}
-mkLam :: [OutBndr] -> OutExpr -> SimplM OutExpr
+mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplM OutExpr
 -- mkLam tries three things
 --	a) eta reduction, if that gives a trivial expression
 --	b) eta expansion [only if there are some value lambdas]
 
-mkLam [] body 
+mkLam _b [] body 
   = return body
-mkLam bndrs body
+mkLam _env bndrs body
   = do	{ dflags <- getDOptsSmpl
 	; mkLam' dflags bndrs body }
   where
@@ -847,7 +858,7 @@ mkLam bndrs body
 
       | dopt Opt_DoLambdaEtaExpansion dflags,
    	any isRuntimeVar bndrs
-      = do { body' <- tryEtaExpansion dflags body
+      = do { let body' = tryEtaExpansion dflags body
  	   ; return (mkLams bndrs body') }
    
       | otherwise 
@@ -1032,11 +1043,10 @@ when computing arity; and etaExpand adds the coerces as necessary when
 actually computing the expansion.
 
 \begin{code}
-tryEtaExpansion :: DynFlags -> OutExpr -> SimplM OutExpr
+tryEtaExpansion :: DynFlags -> OutExpr -> OutExpr
 -- There is at least one runtime binder in the binders
-tryEtaExpansion dflags body = do
-    us <- getUniquesM
-    return (etaExpand fun_arity us body (exprType body))
+tryEtaExpansion dflags body
+  = etaExpand fun_arity body
   where
     fun_arity = exprEtaExpandArity dflags body
 \end{code}
@@ -1189,7 +1199,7 @@ abstractFloats main_tvs body_env body
       = do { uniq <- getUniqueM
 	   ; let  poly_name = setNameUnique (idName var) uniq		-- Keep same name
 		  poly_ty   = mkForAllTys tvs_here (idType var)	-- But new type of course
-		  poly_id   = transferPolyIdInfo var $ 	-- Note [transferPolyIdInfo] in Id.lhs
+		  poly_id   = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.lhs
 			      mkLocalId poly_name poly_ty 
 	   ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }
 		-- In the olden days, it was crucial to copy the occInfo of the original var,