X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUnfold.lhs;h=e54acc0f1038dd39651ffe381b9fea2b699baa12;hb=5e218036aabd1666ff2b509436e4e88491596c37;hp=18a04455fb376099c25a8f39fd7904cb11133ee0;hpb=a51fe79ebcdcb8285573a18f12cade2101533419;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 18a0445..e54acc0 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -104,20 +104,20 @@ mkDFunUnfolding dfun_ty ops
 
 mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
 mkWwInlineRule id expr arity
-  = mkCoreUnfolding True (InlineWrapper id) 
+  = mkCoreUnfolding (InlineWrapper id) True
                    (simpleOptExpr expr) arity
                    (UnfWhen unSaturatedOk boringCxtNotOk)
 
 mkCompulsoryUnfolding :: CoreExpr -> Unfolding
 mkCompulsoryUnfolding expr	   -- Used for things that absolutely must be unfolded
-  = mkCoreUnfolding True InlineCompulsory
+  = mkCoreUnfolding InlineCompulsory True
                     expr 0    -- Arity of unfolding doesn't matter
                     (UnfWhen unSaturatedOk boringCxtOk)
 
 mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding
 mkInlineUnfolding mb_arity expr 
-  = mkCoreUnfolding True 	 -- Note [Top-level flag on inline rules]
-    		    InlineStable
+  = mkCoreUnfolding InlineStable
+    		    True 	 -- Note [Top-level flag on inline rules]
                     expr' arity 
 		    (UnfWhen unsat_ok boring_ok)
   where
@@ -135,18 +135,19 @@ mkInlineUnfolding mb_arity expr
 
 mkInlinableUnfolding :: CoreExpr -> Unfolding
 mkInlinableUnfolding expr
-  = mkUnfolding InlineStable True is_bot expr
+  = mkUnfolding InlineStable True is_bot expr'
   where
-    is_bot = isJust (exprBotStrictness_maybe expr)
+    expr' = simpleOptExpr expr
+    is_bot = isJust (exprBotStrictness_maybe expr')
 \end{code}
 
 Internal functions
 
 \begin{code}
-mkCoreUnfolding :: Bool -> UnfoldingSource -> CoreExpr
+mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
                 -> Arity -> UnfoldingGuidance -> Unfolding
 -- Occurrence-analyses the expression before capturing it
-mkCoreUnfolding top_lvl src expr arity guidance 
+mkCoreUnfolding src top_lvl expr arity guidance 
   = CoreUnfolding { uf_tmpl   	  = occurAnalyseExpr expr,
     		    uf_src        = src,
     		    uf_arity      = arity,
@@ -870,7 +871,7 @@ But the defn of GHC.Classes.$dmmin is:
     {- Arity: 3, HasNoCafRefs, Strictness: SLL,
        Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a ->
                    case @ a GHC.Classes.<= @ a $dOrd x y of wild {
-                     GHC.Bool.False -> y GHC.Bool.True -> x }) -}
+                     GHC.Types.False -> y GHC.Types.True -> x }) -}
 
 We *really* want to inline $dmmin, even though it has arity 3, in
 order to unravel the recursion.
@@ -1162,13 +1163,14 @@ However e might not *look* as if
 -- where t1..tk are the *universally-qantified* type args of 'dc'
 exprIsConApp_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
 
-exprIsConApp_maybe id_unf (Note _ expr)
+exprIsConApp_maybe id_unf (Note note expr)
+  | notSccNote note
   = exprIsConApp_maybe id_unf expr
-	-- We ignore all notes.  For example,
+	-- We ignore all notes except SCCs.  For example,
 	--  	case _scc_ "foo" (C a b) of
 	--			C a b -> e
-	-- should be optimised away, but it will be only if we look
-	-- through the SCC note.
+	-- should not be optimised away, because we'll lose the
+	-- entry count on 'foo'; see Trac #4414
 
 exprIsConApp_maybe id_unf (Cast expr co)
   =     -- Here we do the KPush reduction rule as described in the FC paper
@@ -1307,4 +1309,4 @@ Note [DFun arity check]
 ~~~~~~~~~~~~~~~~~~~~~~~
 Here we check that the total number of supplied arguments (inclding 
 type args) matches what the dfun is expecting.  This may be *less*
-than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
\ No newline at end of file
+than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn