Fix #4346 (INLINABLE pragma not behaving consistently)

Debugged thanks to lots of help from Simon PJ: we weren't updating the
UnfoldingGuidance when the unfolding changed.
Also, a bit of refactoring and additinoal comments.

diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 5e03e4d..1181931 100644 (file)
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -483,7 +483,20 @@ data UnfoldingSource
                       -- Replace uf_tmpl each time around
 
   | InlineStable       -- From an INLINE or INLINABLE pragma 
                       -- Replace uf_tmpl each time around
 
   | InlineStable       -- From an INLINE or INLINABLE pragma 

-                      -- Do not replace uf_tmpl; instead, keep it unchanged
+                       --   INLINE     if guidance is UnfWhen
+                       --   INLINABLE  if guidance is UnfIfGoodArgs
+                       -- (well, technically an INLINABLE might be made
+                       -- UnfWhen if it was small enough, and then
+                       -- it will behave like INLINE outside the current
+                       -- module, but that is the way automatic unfoldings
+                       -- work so it is consistent with the intended
+                       -- meaning of INLINABLE).
+                       --
+                      -- uf_tmpl may change, but only as a result of
+                       -- gentle simplification, it doesn't get updated
+                       -- to the current RHS during compilation as with
+                       -- InlineRhs.
+                       --

                       -- See Note [InlineRules]
 
   | InlineCompulsory   -- Something that *has* no binding, so you *must* inline it
                       -- See Note [InlineRules]
 
   | InlineCompulsory   -- Something that *has* no binding, so you *must* inline it

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 18a0445..7ab0e23 100644 (file)
--- 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
 
 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
                    (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 
                     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
                     expr' arity 
                    (UnfWhen unsat_ok boring_ok)
   where

@@ -135,18 +135,19 @@ mkInlineUnfolding mb_arity expr
 
 mkInlinableUnfolding :: CoreExpr -> Unfolding
 mkInlinableUnfolding expr
 
 mkInlinableUnfolding :: CoreExpr -> Unfolding
 mkInlinableUnfolding expr

-  = mkUnfolding InlineStable True is_bot expr
+  = mkUnfolding InlineStable True is_bot expr'

   where
   where

-    is_bot = isJust (exprBotStrictness_maybe expr)
+    expr' = simpleOptExpr expr
+    is_bot = isJust (exprBotStrictness_maybe expr')

 \end{code}
 
 Internal functions
 
 \begin{code}
 \end{code}
 
 Internal functions
 
 \begin{code}

-mkCoreUnfolding :: Bool -> UnfoldingSource -> CoreExpr
+mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr

                 -> Arity -> UnfoldingGuidance -> Unfolding
 -- Occurrence-analyses the expression before capturing it
                 -> 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,
   = CoreUnfolding { uf_tmpl      = occurAnalyseExpr expr,
                    uf_src        = src,
                    uf_arity      = arity,

@@ -1307,4 +1308,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*
 ~~~~~~~~~~~~~~~~~~~~~~~
 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

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index c753375..3d40b38 100644 (file)
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -212,10 +212,12 @@ data IfaceInfoItem
 
 data IfaceUnfolding 
   = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding
 
 data IfaceUnfolding 
   = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding

+                                -- Possibly could eliminate the Bool here, the information
+                                -- is also in the InlinePragma.

 
   | IfCompulsory IfaceExpr     -- Only used for default methods, in fact
 
 
   | IfCompulsory IfaceExpr     -- Only used for default methods, in fact
 

-  | IfInlineRule Arity 
+  | IfInlineRule Arity          -- INLINE pragmas

                  Bool          -- OK to inline even if *un*-saturated
                 Bool           -- OK to inline even if context is boring
                  IfaceExpr 
                  Bool          -- OK to inline even if *un*-saturated
                 Bool           -- OK to inline even if context is boring
                  IfaceExpr 

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index cbb74be..ba1da60 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -1034,7 +1034,7 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
   = do         { mb_expr <- tcPragExpr name if_expr
        ; return (case mb_expr of
                    Nothing   -> NoUnfolding
   = do         { mb_expr <- tcPragExpr name if_expr
        ; return (case mb_expr of
                    Nothing   -> NoUnfolding

-                   Just expr -> mkCoreUnfolding True InlineStable expr arity 
+                   Just expr -> mkCoreUnfolding InlineStable True expr arity 

                                                  (UnfWhen unsat_ok boring_ok))
     }
 
                                                  (UnfWhen unsat_ok boring_ok))
     }
 

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 9e73359..2e1110f 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -718,8 +718,17 @@ simplUnfolding env top_lvl id _ _
   | isStableSource src
   = do { expr' <- simplExpr rule_env expr
        ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src
   | isStableSource src
   = do { expr' <- simplExpr rule_env expr
        ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src

-       ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) }
+             is_top_lvl = isTopLevel top_lvl
+       ; case guide of
+           UnfIfGoodArgs{} ->
+              return (mkUnfolding src' is_top_lvl (isBottomingId id) expr')
+                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE
+                -- unfolding, and we need to make sure the guidance is kept up
+                -- to date with respect to any changes in the unfolding.
+           _other -> 
+              return (mkCoreUnfolding src' is_top_lvl expr' arity guide)

                -- See Note [Top-level flag on inline rules] in CoreUnfold
                -- See Note [Top-level flag on inline rules] in CoreUnfold

+       }

   where
     act      = idInlineActivation id
     rule_env = updMode (updModeForInlineRules act) env
   where
     act      = idInlineActivation id
     rule_env = updMode (updModeForInlineRules act) env