X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FcoreSyn%2FCoreUnfold.lhs;h=d1b9fa04129de2a724ef9eb90f68a4f01a907a05;hb=c406b5bde899dd2b28e5239937c909d675bca356;hp=dfbb3223dac99c8576985e02833a04e6bf9c693c;hpb=62af0377c41ffcc76ae308e07e328106846f050c;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index dfbb322..d1b9fa0 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -41,8 +41,8 @@ import StaticFlags
 import DynFlags
 import CoreSyn
 import PprCore		()	-- Instances
-import TcType	 	( tcSplitSigmaTy, tcSplitDFunHead )
-import OccurAnal
+import TcType           ( tcSplitDFunTy )
+import OccurAnal        ( occurAnalyseExpr )
 import CoreSubst hiding( substTy )
 import CoreFVs         ( exprFreeVars )
 import CoreArity       ( manifestArity, exprBotStrictness_maybe )
@@ -54,8 +54,7 @@ import Literal
 import PrimOp
 import IdInfo
 import BasicTypes	( Arity )
-import TcType		( tcSplitDFunTy )
-import Type 
+import Type
 import Coercion
 import PrelNames
 import VarEnv           ( mkInScopeSet )
@@ -95,11 +94,8 @@ mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding
 mkDFunUnfolding dfun_ty ops 
   = DFunUnfolding dfun_nargs data_con ops
   where
-    (tvs, theta, head_ty) = tcSplitSigmaTy dfun_ty
-    	  -- NB: tcSplitSigmaTy: do not look through a newtype
-	  --     when the dictionary type is a newtype
-    (cls, _)   = tcSplitDFunHead head_ty
-    dfun_nargs = length tvs + length theta
+    (tvs, n_theta, cls, _) = tcSplitDFunTy dfun_ty
+    dfun_nargs = length tvs + n_theta
     data_con   = classDataCon cls
 
 mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
@@ -787,21 +783,21 @@ callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
       -- be a loop breaker  (maybe the knot is not yet untied)
 	CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top 
 		      , uf_is_cheap = is_cheap, uf_arity = uf_arity
-                      , uf_guidance = guidance }
+                      , uf_guidance = guidance, uf_expandable = is_exp }
           | active_unfolding -> tryUnfolding dflags id lone_variable 
                                     arg_infos cont_info unf_template is_top 
-                                    is_cheap uf_arity guidance
+                                    is_cheap is_exp uf_arity guidance
           | otherwise    -> Nothing
 	NoUnfolding 	 -> Nothing 
 	OtherCon {} 	 -> Nothing 
 	DFunUnfolding {} -> Nothing 	-- Never unfold a DFun
 
 tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt
-             -> CoreExpr -> Bool -> Bool -> Arity -> UnfoldingGuidance
+             -> CoreExpr -> Bool -> Bool -> Bool -> Arity -> UnfoldingGuidance
 	     -> Maybe CoreExpr	
 tryUnfolding dflags id lone_variable 
              arg_infos cont_info unf_template is_top 
-             is_cheap uf_arity guidance
+             is_cheap is_exp uf_arity guidance
 			-- uf_arity will typically be equal to (idArity id), 
 			-- but may be less for InlineRules
  | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
@@ -810,6 +806,7 @@ tryUnfolding dflags id lone_variable
 			text "uf arity" <+> ppr uf_arity,
 			text "interesting continuation" <+> ppr cont_info,
 			text "some_benefit" <+> ppr some_benefit,
+                        text "is exp:" <+> ppr is_exp,
                         text "is cheap:" <+> ppr is_cheap,
 			text "guidance" <+> ppr guidance,
 			extra_doc,
@@ -843,10 +840,10 @@ tryUnfolding dflags id lone_variable
 
     interesting_saturated_call 
       = case cont_info of
-          BoringCtxt -> not is_top && uf_arity > 0	      -- Note [Nested functions]
+          BoringCtxt -> not is_top && uf_arity > 0	  -- Note [Nested functions]
           CaseCtxt   -> not (lone_variable && is_cheap)   -- Note [Lone variables]
-          ArgCtxt {} -> uf_arity > 0     		      -- Note [Inlining in ArgCtxt]
-          ValAppCtxt -> True			      -- Note [Cast then apply]
+          ArgCtxt {} -> uf_arity > 0     		  -- Note [Inlining in ArgCtxt]
+          ValAppCtxt -> True			          -- Note [Cast then apply]
 
     (yes_or_no, extra_doc)
       = case guidance of
@@ -1285,7 +1282,7 @@ exprIsConApp_maybe id_unf expr
         , let sat = length args == dfun_nargs    -- See Note [DFun arity check]
           in if sat then True else 
              pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False   
-        , let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
+        , let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
               subst    = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
               mk_arg (DFunConstArg e) = e
               mk_arg (DFunLamArg i)   = args !! i