Implement INLINABLE pragma
authorsimonpj@microsoft.com <unknown>
Wed, 15 Sep 2010 12:44:42 +0000 (12:44 +0000)
committersimonpj@microsoft.com <unknown>
Wed, 15 Sep 2010 12:44:42 +0000 (12:44 +0000)
Implements Trac #4299.  Documentation to come.

30 files changed:
compiler/basicTypes/BasicTypes.lhs
compiler/basicTypes/MkId.lhs
compiler/coreSyn/CoreFVs.lhs
compiler/coreSyn/CoreSubst.lhs
compiler/coreSyn/CoreSyn.lhs
compiler/coreSyn/CoreUnfold.lhs
compiler/coreSyn/PprCore.lhs
compiler/deSugar/DsBinds.lhs
compiler/deSugar/DsForeign.lhs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.lhs
compiler/iface/BinIface.hs
compiler/iface/IfaceSyn.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/main/TidyPgm.lhs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs
compiler/simplCore/OccurAnal.lhs
compiler/simplCore/SetLevels.lhs
compiler/simplCore/Simplify.lhs
compiler/specialise/Specialise.lhs
compiler/stranal/WorkWrap.lhs
compiler/vectorise/Vectorise.hs
compiler/vectorise/Vectorise/Exp.hs
compiler/vectorise/Vectorise/Type/Env.hs
compiler/vectorise/Vectorise/Type/PADict.hs
compiler/vectorise/Vectorise/Utils/Closure.hs
compiler/vectorise/Vectorise/Utils/Hoisting.hs

index 8cd5c35..f125714 100644 (file)
@@ -62,8 +62,10 @@ module BasicTypes(
        CompilerPhase, 
        Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
         RuleMatchInfo(..), isConLike, isFunLike, 
        CompilerPhase, 
        Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
         RuleMatchInfo(..), isConLike, isFunLike, 
-        InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma,
-       isDefaultInlinePragma, isInlinePragma, inlinePragmaSat,
+        InlineSpec(..), 
+        InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, 
+        neverInlinePragma, dfunInlinePragma, 
+       isDefaultInlinePragma, isInlinePragma, inlinePragmaSpec, inlinePragmaSat,
         inlinePragmaActivation, inlinePragmaRuleMatchInfo,
         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
 
         inlinePragmaActivation, inlinePragmaRuleMatchInfo,
         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
 
@@ -645,12 +647,12 @@ data Activation = NeverActive
 
 data RuleMatchInfo = ConLike                   -- See Note [CONLIKE pragma]
                    | FunLike
 
 data RuleMatchInfo = ConLike                   -- See Note [CONLIKE pragma]
                    | FunLike
-                   deriving( Eq, Data, Typeable )
+                   deriving( Eq, Data, Typeable, Show )
+       -- Show needed for Lexer.x
 
 data InlinePragma           -- Note [InlinePragma]
   = InlinePragma
 
 data InlinePragma           -- Note [InlinePragma]
   = InlinePragma
-      { inl_inline :: Bool           -- True <=> INLINE, 
-                                    -- False <=> no pragma at all, or NOINLINE
+      { inl_inline :: InlineSpec
 
       , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n 
                                     --            explicit (non-type, non-dictionary) args
 
       , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n 
                                     --            explicit (non-type, non-dictionary) args
@@ -663,6 +665,14 @@ data InlinePragma               -- Note [InlinePragma]
 
       , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?
     } deriving( Eq, Data, Typeable )
 
       , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?
     } deriving( Eq, Data, Typeable )
+
+data InlineSpec   -- What the user's INLINE pragama looked like
+  = Inline
+  | Inlinable
+  | NoInline
+  | EmptyInlineSpec
+  deriving( Eq, Data, Typeable, Show )
+       -- Show needed for Lexer.x
 \end{code}
 
 Note [InlinePragma]
 \end{code}
 
 Note [InlinePragma]
@@ -725,16 +735,24 @@ isFunLike :: RuleMatchInfo -> Bool
 isFunLike FunLike = True
 isFunLike _            = False
 
 isFunLike FunLike = True
 isFunLike _            = False
 
+isInlineSpec :: InlineSpec -> Bool
+isInlineSpec Inline    = True
+isInlineSpec Inlinable = True
+isInlineSpec _         = False
+
 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
   :: InlinePragma
 defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
                                    , inl_rule = FunLike
 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
   :: InlinePragma
 defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
                                    , inl_rule = FunLike
-                                   , inl_inline = False
+                                   , inl_inline = EmptyInlineSpec
                                    , inl_sat = Nothing }
 
                                    , inl_sat = Nothing }
 
-alwaysInlinePragma = defaultInlinePragma { inl_inline = True }
+alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }
 neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive }
 
 neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive }
 
+inlinePragmaSpec :: InlinePragma -> InlineSpec
+inlinePragmaSpec = inl_inline
+
 -- A DFun has an always-active inline activation so that 
 -- exprIsConApp_maybe can "see" its unfolding
 -- (However, its actual Unfolding is a DFunUnfolding, which is
 -- A DFun has an always-active inline activation so that 
 -- exprIsConApp_maybe can "see" its unfolding
 -- (However, its actual Unfolding is a DFunUnfolding, which is
@@ -746,10 +764,10 @@ isDefaultInlinePragma :: InlinePragma -> Bool
 isDefaultInlinePragma (InlinePragma { inl_act = activation
                                     , inl_rule = match_info
                                     , inl_inline = inline })
 isDefaultInlinePragma (InlinePragma { inl_act = activation
                                     , inl_rule = match_info
                                     , inl_inline = inline })
-  = not inline && isAlwaysActive activation && isFunLike match_info
+  = isInlineSpec inline && isAlwaysActive activation && isFunLike match_info
 
 isInlinePragma :: InlinePragma -> Bool
 
 isInlinePragma :: InlinePragma -> Bool
-isInlinePragma prag = inl_inline prag
+isInlinePragma prag = isInlineSpec (inl_inline prag)
 
 inlinePragmaSat :: InlinePragma -> Maybe Arity
 inlinePragmaSat = inl_sat
 
 inlinePragmaSat :: InlinePragma -> Maybe Arity
 inlinePragmaSat = inl_sat
@@ -776,16 +794,20 @@ instance Outputable RuleMatchInfo where
    ppr ConLike = ptext (sLit "CONLIKE")
    ppr FunLike = ptext (sLit "FUNLIKE")
 
    ppr ConLike = ptext (sLit "CONLIKE")
    ppr FunLike = ptext (sLit "FUNLIKE")
 
+instance Outputable InlineSpec where
+   ppr Inline          = ptext (sLit "INLINE")
+   ppr NoInline        = ptext (sLit "NOINLINE")
+   ppr Inlinable       = ptext (sLit "INLINABLE")
+   ppr EmptyInlineSpec = empty
+
 instance Outputable InlinePragma where
   ppr (InlinePragma { inl_inline = inline, inl_act = activation
                     , inl_rule = info, inl_sat = mb_arity })
 instance Outputable InlinePragma where
   ppr (InlinePragma { inl_inline = inline, inl_act = activation
                     , inl_rule = info, inl_sat = mb_arity })
-    = pp_inl_act (inline, activation) <+> pp_sat <+> pp_info 
+    = ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info 
     where
     where
-      pp_inl_act (False, AlwaysActive)  = empty        -- defaultInlinePragma
-      pp_inl_act (False, NeverActive)   = ptext (sLit "NOINLINE")
-      pp_inl_act (False, act)           = ptext (sLit "NOINLINE") <> ppr act
-      pp_inl_act (True,  AlwaysActive)  = ptext (sLit "INLINE")
-      pp_inl_act (True,  act)           = ptext (sLit "INLINE") <> ppr act
+      pp_act Inline   AlwaysActive = empty     
+      pp_act NoInline NeverActive  = empty
+      pp_act _        act          = ppr act
 
       pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> int ar)
              | otherwise           = empty
 
       pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> int ar)
              | otherwise           = empty
index 774c919..4c41d28 100644 (file)
@@ -317,7 +317,7 @@ mkDataConIds wrap_name wkr_name data_con
         --      ...(let w = C x in ...(w p q)...)...
         -- we want to see that w is strict in its two arguments
 
         --      ...(let w = C x in ...(w p q)...)...
         -- we want to see that w is strict in its two arguments
 
-    wrap_unf = mkInlineRule wrap_rhs (Just (length dict_args + length id_args))
+    wrap_unf = mkInlineUnfolding (Just (length dict_args + length id_args)) wrap_rhs
     wrap_rhs = mkLams wrap_tvs $ 
                mkLams eq_args $
                mkLams dict_args $ mkLams id_args $
     wrap_rhs = mkLams wrap_tvs $ 
                mkLams eq_args $
                mkLams dict_args $ mkLams id_args $
index e5cbfc4..90d7619 100644 (file)
@@ -422,7 +422,7 @@ idUnfoldingVars :: Id -> VarSet
 idUnfoldingVars id
   = case realIdUnfolding id of
       CoreUnfolding { uf_tmpl = rhs, uf_src = src }
 idUnfoldingVars id
   = case realIdUnfolding id of
       CoreUnfolding { uf_tmpl = rhs, uf_src = src }
-                            | isInlineRuleSource src
+                            | isStableSource src
                             -> exprFreeVars rhs
       DFunUnfolding _ _ args -> exprsFreeVars args
       _                      -> emptyVarSet
                             -> exprFreeVars rhs
       DFunUnfolding _ _ args -> exprsFreeVars args
       _                      -> emptyVarSet
index 4f92b1a..7ca5a67 100644 (file)
@@ -555,9 +555,9 @@ substUnfolding subst (DFunUnfolding ar con args)
 
 substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
        -- Retain an InlineRule!
 
 substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
        -- Retain an InlineRule!
-  | not (isInlineRuleSource src)  -- Always zap a CoreUnfolding, to save substitution work
+  | not (isStableSource src)  -- Zap an unstable unfolding, to save substitution work
   = NoUnfolding
   = NoUnfolding
-  | otherwise                     -- But keep an InlineRule!
+  | otherwise                 -- But keep a stable one!
   = seqExpr new_tmpl `seq` 
     new_src `seq`
     unf { uf_tmpl = new_tmpl, uf_src = new_src }
   = seqExpr new_tmpl `seq` 
     new_src `seq`
     unf { uf_tmpl = new_tmpl, uf_src = new_src }
@@ -576,7 +576,7 @@ substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr)
       _other -> -- WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr 
                 --             <+> ifPprDebug (equals <+> ppr wkr_expr) )   
                              -- Note [Worker inlining]
       _other -> -- WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr 
                 --             <+> ifPprDebug (equals <+> ppr wkr_expr) )   
                              -- Note [Worker inlining]
-                InlineRule    -- It's not a wrapper any more, but still inline it!
+                InlineStable  -- It's not a wrapper any more, but still inline it!
 
   | Just w1  <- lookupInScope in_scope wkr = InlineWrapper w1
   | otherwise = -- WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr )
 
   | Just w1  <- lookupInScope in_scope wkr = InlineWrapper w1
   | otherwise = -- WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr )
@@ -584,7 +584,7 @@ substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr)
                -- dropped as dead code, because we don't treat the UnfoldingSource
                -- as an "occurrence".
                 -- Note [Worker inlining]
                -- dropped as dead code, because we don't treat the UnfoldingSource
                -- as an "occurrence".
                 -- Note [Worker inlining]
-               InlineRule
+               InlineStable
 
 substUnfoldingSource _ src = src
 
 
 substUnfoldingSource _ src = src
 
index e09e4f2..05cc575 100644 (file)
@@ -48,8 +48,9 @@ module CoreSyn (
        maybeUnfoldingTemplate, otherCons, unfoldingArity,
        isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
        maybeUnfoldingTemplate, otherCons, unfoldingArity,
        isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
-       isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding, 
-       isStableUnfolding, canUnfold, neverUnfoldGuidance, isInlineRuleSource,
+       isStableUnfolding, isStableUnfolding_maybe, 
+        isClosedUnfolding, hasSomeUnfolding, 
+       canUnfold, neverUnfoldGuidance, isStableSource,
 
        -- * Strictness
        seqExpr, seqExprs, seqUnfolding, 
 
        -- * Strictness
        seqExpr, seqExprs, seqUnfolding, 
@@ -433,17 +434,20 @@ data Unfolding
                        -- They are usually variables, but can be trivial expressions
                        -- instead (e.g. a type application).  
 
                        -- They are usually variables, but can be trivial expressions
                        -- instead (e.g. a type application).  
 
-  | CoreUnfolding {            -- An unfolding for an Id with no pragma, or perhaps a NOINLINE pragma
-                               -- (For NOINLINE, the phase, if any, is in the InlinePragInfo for this Id.)
+  | CoreUnfolding {            -- An unfolding for an Id with no pragma, 
+                                -- or perhaps a NOINLINE pragma
+                               -- (For NOINLINE, the phase, if any, is in the 
+                                -- InlinePragInfo for this Id.)
        uf_tmpl       :: CoreExpr,        -- Template; occurrence info is correct
        uf_src        :: UnfoldingSource, -- Where the unfolding came from
        uf_is_top     :: Bool,          -- True <=> top level binding
        uf_arity      :: Arity,         -- Number of value arguments expected
        uf_tmpl       :: CoreExpr,        -- Template; occurrence info is correct
        uf_src        :: UnfoldingSource, -- Where the unfolding came from
        uf_is_top     :: Bool,          -- True <=> top level binding
        uf_arity      :: Arity,         -- Number of value arguments expected
-       uf_is_value   :: Bool,          -- exprIsHNF template (cached); it is ok to discard a `seq` on
-                                       --      this variable
-        uf_is_conlike :: Bool,          -- True <=> application of constructor or CONLIKE function
+       uf_is_value   :: Bool,          -- exprIsHNF template (cached); it is ok to discard 
+                                       --      a `seq` on this variable
+        uf_is_conlike :: Bool,          -- True <=> applicn of constructor or CONLIKE function
                                         --      Cached version of exprIsConLike
                                         --      Cached version of exprIsConLike
-       uf_is_cheap   :: Bool,          -- True <=> doesn't waste (much) work to expand inside an inlining
+       uf_is_cheap   :: Bool,          -- True <=> doesn't waste (much) work to expand 
+                                        --          inside an inlining
                                        --      Cached version of exprIsCheap
        uf_expandable :: Bool,          -- True <=> can expand in RULE matching
                                        --      Cached version of exprIsExpandable
                                        --      Cached version of exprIsCheap
        uf_expandable :: Bool,          -- True <=> can expand in RULE matching
                                        --      Cached version of exprIsExpandable
@@ -467,13 +471,18 @@ data Unfolding
 
 ------------------------------------------------
 data UnfoldingSource 
 
 ------------------------------------------------
 data UnfoldingSource 
-  = InlineCompulsory   -- Something that *has* no binding, so you *must* inline it
+  = InlineRhs          -- The current rhs of the function
+                      -- Replace uf_tmpl each time around
+
+  | InlineStable       -- From an INLINE or INLINABLE pragma 
+                      -- Do not replace uf_tmpl; instead, keep it unchanged
+                      -- See Note [InlineRules]
+
+  | InlineCompulsory   -- Something that *has* no binding, so you *must* inline it
                       -- Only a few primop-like things have this property 
                        -- (see MkId.lhs, calls to mkCompulsoryUnfolding).
                        -- Inline absolutely always, however boring the context.
 
                       -- Only a few primop-like things have this property 
                        -- (see MkId.lhs, calls to mkCompulsoryUnfolding).
                        -- Inline absolutely always, however boring the context.
 
-  | InlineRule        -- From an {-# INLINE #-} pragma; See Note [InlineRules]
-
   | InlineWrapper Id   -- This unfolding is a the wrapper in a 
                       --     worker/wrapper split from the strictness analyser
                       -- The Id is the worker-id
   | InlineWrapper Id   -- This unfolding is a the wrapper in a 
                       --     worker/wrapper split from the strictness analyser
                       -- The Id is the worker-id
@@ -481,10 +490,6 @@ data UnfoldingSource
                       --       which don't need to contain the RHS; 
                       --       it can be derived from the strictness info
 
                       --       which don't need to contain the RHS; 
                       --       it can be derived from the strictness info
 
-  | InlineRhs          -- The current rhs of the function
-
-   -- For InlineRhs, the uf_tmpl is replaced each time around
-   -- For all the others we leave uf_tmpl alone
 
 
 -- | 'UnfoldingGuidance' says when unfolding should take place
 
 
 -- | 'UnfoldingGuidance' says when unfolding should take place
@@ -579,11 +584,12 @@ seqGuidance _                      = ()
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
-isInlineRuleSource :: UnfoldingSource -> Bool
-isInlineRuleSource InlineCompulsory   = True
-isInlineRuleSource InlineRule         = True
-isInlineRuleSource (InlineWrapper {}) = True
-isInlineRuleSource InlineRhs          = False
+isStableSource :: UnfoldingSource -> Bool
+-- Keep the unfolding template
+isStableSource InlineCompulsory   = True
+isStableSource InlineStable       = True
+isStableSource (InlineWrapper {}) = True
+isStableSource InlineRhs          = False
  
 -- | Retrieves the template of an unfolding: panics if none is known
 unfoldingTemplate :: Unfolding -> CoreExpr
  
 -- | Retrieves the template of an unfolding: panics if none is known
 unfoldingTemplate :: Unfolding -> CoreExpr
@@ -642,19 +648,15 @@ expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr
 expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
 expandUnfolding_maybe _                                                       = Nothing
 
 expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
 expandUnfolding_maybe _                                                       = Nothing
 
-isInlineRule :: Unfolding -> Bool
-isInlineRule (CoreUnfolding { uf_src = src }) = isInlineRuleSource src
-isInlineRule _                               = False
-
-isInlineRule_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool)
-isInlineRule_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide }) 
-   | isInlineRuleSource src
+isStableUnfolding_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool)
+isStableUnfolding_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide }) 
+   | isStableSource src
    = Just (src, unsat_ok)
    where
      unsat_ok = case guide of
                  UnfWhen unsat_ok _ -> unsat_ok
                   _                  -> needSaturated
    = Just (src, unsat_ok)
    where
      unsat_ok = case guide of
                  UnfWhen unsat_ok _ -> unsat_ok
                   _                  -> needSaturated
-isInlineRule_maybe _ = Nothing
+isStableUnfolding_maybe _ = Nothing
 
 isCompulsoryUnfolding :: Unfolding -> Bool
 isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
 
 isCompulsoryUnfolding :: Unfolding -> Bool
 isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
@@ -663,7 +665,7 @@ isCompulsoryUnfolding _                                             = False
 isStableUnfolding :: Unfolding -> Bool
 -- True of unfoldings that should not be overwritten 
 -- by a CoreUnfolding for the RHS of a let-binding
 isStableUnfolding :: Unfolding -> Bool
 -- True of unfoldings that should not be overwritten 
 -- by a CoreUnfolding for the RHS of a let-binding
-isStableUnfolding (CoreUnfolding { uf_src = src }) = isInlineRuleSource src
+isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src
 isStableUnfolding (DFunUnfolding {})              = True
 isStableUnfolding _                                = False
 
 isStableUnfolding (DFunUnfolding {})              = True
 isStableUnfolding _                                = False
 
index 24d6330..18a0445 100644 (file)
@@ -19,8 +19,9 @@ module CoreUnfold (
        Unfolding, UnfoldingGuidance,   -- Abstract types
 
        noUnfolding, mkImplicitUnfolding, 
        Unfolding, UnfoldingGuidance,   -- Abstract types
 
        noUnfolding, mkImplicitUnfolding, 
-       mkTopUnfolding, mkUnfolding, mkCoreUnfolding,
-       mkInlineRule, mkWwInlineRule,
+        mkUnfolding, mkCoreUnfolding,
+       mkTopUnfolding, mkSimpleUnfolding,
+       mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule,
        mkCompulsoryUnfolding, mkDFunUnfolding,
 
        interestingArg, ArgSummary(..),
        mkCompulsoryUnfolding, mkDFunUnfolding,
 
        interestingArg, ArgSummary(..),
@@ -44,7 +45,7 @@ import TcType         ( tcSplitSigmaTy, tcSplitDFunHead )
 import OccurAnal
 import CoreSubst hiding( substTy )
 import CoreFVs         ( exprFreeVars )
 import OccurAnal
 import CoreSubst hiding( substTy )
 import CoreFVs         ( exprFreeVars )
-import CoreArity       ( manifestArity )
+import CoreArity       ( manifestArity, exprBotStrictness_maybe )
 import CoreUtils
 import Id
 import DataCon
 import CoreUtils
 import Id
 import DataCon
@@ -63,7 +64,7 @@ import Util
 import FastTypes
 import FastString
 import Outputable
 import FastTypes
 import FastString
 import Outputable
-
+import Data.Maybe
 \end{code}
 
 
 \end{code}
 
 
@@ -75,8 +76,7 @@ import Outputable
 
 \begin{code}
 mkTopUnfolding :: Bool -> CoreExpr -> Unfolding
 
 \begin{code}
 mkTopUnfolding :: Bool -> CoreExpr -> Unfolding
-mkTopUnfolding is_bottoming expr 
-  = mkUnfolding True {- Top level -} is_bottoming expr
+mkTopUnfolding = mkUnfolding InlineRhs True {- Top level -}
 
 mkImplicitUnfolding :: CoreExpr -> Unfolding
 -- For implicit Ids, do a tiny bit of optimising first
 
 mkImplicitUnfolding :: CoreExpr -> Unfolding
 -- For implicit Ids, do a tiny bit of optimising first
@@ -88,44 +88,8 @@ mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr)
 -- top-level flag to True.  It gets set more accurately by the simplifier
 -- Simplify.simplUnfolding.
 
 -- top-level flag to True.  It gets set more accurately by the simplifier
 -- Simplify.simplUnfolding.
 
-mkUnfolding :: Bool -> Bool -> CoreExpr -> Unfolding
-mkUnfolding top_lvl is_bottoming expr
-  = CoreUnfolding { uf_tmpl      = occurAnalyseExpr expr,
-                   uf_src        = InlineRhs,
-                   uf_arity      = arity,
-                   uf_is_top     = top_lvl,
-                   uf_is_value   = exprIsHNF        expr,
-                    uf_is_conlike = exprIsConLike    expr,
-                   uf_expandable = exprIsExpandable expr,
-                   uf_is_cheap   = is_cheap,
-                   uf_guidance   = guidance }
-  where
-    is_cheap = exprIsCheap expr
-    (arity, guidance) = calcUnfoldingGuidance is_cheap (top_lvl && is_bottoming) 
-                                              opt_UF_CreationThreshold expr
-       -- Sometimes during simplification, there's a large let-bound thing     
-       -- which has been substituted, and so is now dead; so 'expr' contains
-       -- two copies of the thing while the occurrence-analysed expression doesn't
-       -- Nevertheless, we *don't* occ-analyse before computing the size because the
-       -- size computation bales out after a while, whereas occurrence analysis does not.
-       --
-       -- This can occasionally mean that the guidance is very pessimistic;
-       -- it gets fixed up next round.  And it should be rare, because large
-       -- let-bound things that are dead are usually caught by preInlineUnconditionally
-
-mkCoreUnfolding :: Bool -> UnfoldingSource -> CoreExpr
-                -> Arity -> UnfoldingGuidance -> Unfolding
--- Occurrence-analyses the expression before capturing it
-mkCoreUnfolding top_lvl src expr arity guidance 
-  = CoreUnfolding { uf_tmpl      = occurAnalyseExpr expr,
-                   uf_src        = src,
-                   uf_arity      = arity,
-                   uf_is_top     = top_lvl,
-                   uf_is_value   = exprIsHNF        expr,
-                    uf_is_conlike = exprIsConLike    expr,
-                   uf_is_cheap   = exprIsCheap      expr,
-                   uf_expandable = exprIsExpandable expr,
-                   uf_guidance   = guidance }
+mkSimpleUnfolding :: CoreExpr -> Unfolding
+mkSimpleUnfolding = mkUnfolding InlineRhs False False
 
 mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding
 mkDFunUnfolding dfun_ty ops 
 
 mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding
 mkDFunUnfolding dfun_ty ops 
@@ -150,10 +114,11 @@ mkCompulsoryUnfolding expr           -- Used for things that absolutely must be unfolde
                     expr 0    -- Arity of unfolding doesn't matter
                     (UnfWhen unSaturatedOk boringCxtOk)
 
                     expr 0    -- Arity of unfolding doesn't matter
                     (UnfWhen unSaturatedOk boringCxtOk)
 
-mkInlineRule :: CoreExpr -> Maybe Arity -> Unfolding
-mkInlineRule expr mb_arity 
-  = mkCoreUnfolding True InlineRule     -- Note [Top-level flag on inline rules]
-                   expr' arity 
+mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding
+mkInlineUnfolding mb_arity expr 
+  = mkCoreUnfolding True        -- Note [Top-level flag on inline rules]
+                   InlineStable
+                    expr' arity 
                    (UnfWhen unsat_ok boring_ok)
   where
     expr' = simpleOptExpr expr
                    (UnfWhen unsat_ok boring_ok)
   where
     expr' = simpleOptExpr expr
@@ -167,8 +132,58 @@ mkInlineRule expr mb_arity
                  (_, UnfWhen _ boring_ok) -> boring_ok
                  _other                   -> boringCxtNotOk
      -- See Note [INLINE for small functions]
                  (_, UnfWhen _ boring_ok) -> boring_ok
                  _other                   -> boringCxtNotOk
      -- See Note [INLINE for small functions]
+
+mkInlinableUnfolding :: CoreExpr -> Unfolding
+mkInlinableUnfolding expr
+  = mkUnfolding InlineStable True is_bot expr
+  where
+    is_bot = isJust (exprBotStrictness_maybe expr)
 \end{code}
 
 \end{code}
 
+Internal functions
+
+\begin{code}
+mkCoreUnfolding :: Bool -> UnfoldingSource -> CoreExpr
+                -> Arity -> UnfoldingGuidance -> Unfolding
+-- Occurrence-analyses the expression before capturing it
+mkCoreUnfolding top_lvl src expr arity guidance 
+  = CoreUnfolding { uf_tmpl      = occurAnalyseExpr expr,
+                   uf_src        = src,
+                   uf_arity      = arity,
+                   uf_is_top     = top_lvl,
+                   uf_is_value   = exprIsHNF        expr,
+                    uf_is_conlike = exprIsConLike    expr,
+                   uf_is_cheap   = exprIsCheap      expr,
+                   uf_expandable = exprIsExpandable expr,
+                   uf_guidance   = guidance }
+
+mkUnfolding :: UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding
+-- Calculates unfolding guidance
+-- Occurrence-analyses the expression before capturing it
+mkUnfolding src top_lvl is_bottoming expr
+  = CoreUnfolding { uf_tmpl      = occurAnalyseExpr expr,
+                   uf_src        = src,
+                   uf_arity      = arity,
+                   uf_is_top     = top_lvl,
+                   uf_is_value   = exprIsHNF        expr,
+                    uf_is_conlike = exprIsConLike    expr,
+                   uf_expandable = exprIsExpandable expr,
+                   uf_is_cheap   = is_cheap,
+                   uf_guidance   = guidance }
+  where
+    is_cheap = exprIsCheap expr
+    (arity, guidance) = calcUnfoldingGuidance is_cheap (top_lvl && is_bottoming) 
+                                              opt_UF_CreationThreshold expr
+       -- Sometimes during simplification, there's a large let-bound thing     
+       -- which has been substituted, and so is now dead; so 'expr' contains
+       -- two copies of the thing while the occurrence-analysed expression doesn't
+       -- Nevertheless, we *don't* occ-analyse before computing the size because the
+       -- size computation bales out after a while, whereas occurrence analysis does not.
+       --
+       -- This can occasionally mean that the guidance is very pessimistic;
+       -- it gets fixed up next round.  And it should be rare, because large
+       -- let-bound things that are dead are usually caught by preInlineUnconditionally
+\end{code}
 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *
index 1908667..3752d1d 100644 (file)
@@ -382,7 +382,7 @@ instance Outputable UnfoldingGuidance where
 instance Outputable UnfoldingSource where
   ppr InlineCompulsory  = ptext (sLit "Compulsory")
   ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w
 instance Outputable UnfoldingSource where
   ppr InlineCompulsory  = ptext (sLit "Compulsory")
   ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w
-  ppr InlineRule        = ptext (sLit "InlineRule")
+  ppr InlineStable      = ptext (sLit "InlineStable")
   ppr InlineRhs         = ptext (sLit "<vanilla>")
 
 instance Outputable Unfolding where
   ppr InlineRhs         = ptext (sLit "<vanilla>")
 
 instance Outputable Unfolding where
@@ -407,8 +407,8 @@ instance Outputable Unfolding where
                 , ptext (sLit "Expandable=") <> ppr exp
                 , ptext (sLit "Guidance=")   <> ppr g ]
       pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
                 , ptext (sLit "Expandable=") <> ppr exp
                 , ptext (sLit "Guidance=")   <> ppr g ]
       pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
-      pp_rhs | isInlineRuleSource src = pp_tmpl
-             | otherwise              = empty
+      pp_rhs | isStableSource src = pp_tmpl
+             | otherwise          = empty
             -- Don't print the RHS or we get a quadratic 
            -- blowup in the size of the printout!
 \end{code}
             -- Don't print the RHS or we get a quadratic 
            -- blowup in the size of the printout!
 \end{code}
index c886c8e..17333af 100644 (file)
@@ -355,21 +355,29 @@ makeCorePair gbl_id is_default_method dict_arity rhs
   | is_default_method                -- Default methods are *always* inlined
   = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
 
   | is_default_method                -- Default methods are *always* inlined
   = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
 
-  | not (isInlinePragma inline_prag)
-  = (gbl_id, rhs)
+  | otherwise
+  = case inlinePragmaSpec inline_prag of
+         EmptyInlineSpec -> (gbl_id, rhs)
+         NoInline        -> (gbl_id, rhs)
+         Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
+          Inline          -> inline_pair
 
 
-  | Just arity <- inlinePragmaSat inline_prag
+  where
+    inline_prag   = idInlinePragma gbl_id
+    inlinable_unf = mkInlinableUnfolding rhs
+    inline_pair
+       | Just arity <- inlinePragmaSat inline_prag
        -- Add an Unfolding for an INLINE (but not for NOINLINE)
        -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
        -- Add an Unfolding for an INLINE (but not for NOINLINE)
        -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
-  , let real_arity = dict_arity + arity
+       , let real_arity = dict_arity + arity
         -- NB: The arity in the InlineRule takes account of the dictionaries
         -- NB: The arity in the InlineRule takes account of the dictionaries
-  = (gbl_id `setIdUnfolding` mkInlineRule rhs (Just real_arity),
-     etaExpand real_arity rhs)
+       = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
+         , etaExpand real_arity rhs)
+
+       | otherwise
+       = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
+         (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
 
 
-  | otherwise
-  = (gbl_id `setIdUnfolding` mkInlineRule rhs Nothing, rhs)
-  where
-    inline_prag = idInlinePragma gbl_id
 
 dictArity :: [Var] -> Arity
 -- Don't count coercion variables in arity
 
 dictArity :: [Var] -> Arity
 -- Don't count coercion variables in arity
index 51f03c2..d73cd53 100644 (file)
@@ -207,7 +207,7 @@ dsFCall fn_id fcall = do
         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
         wrap_rhs     = mkLams (tvs ++ args) wrapper_body
         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
         wrap_rhs     = mkLams (tvs ++ args) wrapper_body
-        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineRule wrap_rhs (Just (length args))
+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs
     
     return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
 \end{code}
     
     return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
 \end{code}
index 3310ffa..b24daea 100644 (file)
@@ -460,15 +460,17 @@ rep_specialise nm ty ispec loc
 rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma
                -> DsM (Core TH.InlineSpecQ)
 rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
 rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma
                -> DsM (Core TH.InlineSpecQ)
 rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
-  | Nothing            <- activation1 
-    = repInlineSpecNoPhase inline1 match1
   | Just (flag, phase) <- activation1 
   | Just (flag, phase) <- activation1 
-    = repInlineSpecPhase inline1 match1 flag phase
-  | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec"
-    where
+  = repInlineSpecPhase inline1 match1 flag phase
+  | otherwise
+  = repInlineSpecNoPhase inline1 match1
+  where
       match1      = coreBool (rep_RuleMatchInfo match)
       activation1 = rep_Activation activation
       match1      = coreBool (rep_RuleMatchInfo match)
       activation1 = rep_Activation activation
-      inline1     = coreBool inline
+      inline1     = case inline of 
+                       Inline -> coreBool True
+                      _other -> coreBool False
+                      -- We have no representation for Inlinable
 
       rep_RuleMatchInfo FunLike = False
       rep_RuleMatchInfo ConLike = True
 
       rep_RuleMatchInfo FunLike = False
       rep_RuleMatchInfo ConLike = True
index d392be2..0ab26ee 100644 (file)
@@ -400,7 +400,7 @@ cvtInlineSpec Nothing
   = defaultInlinePragma
 cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) 
   = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo
   = defaultInlinePragma
 cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) 
   = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo
-                 , inl_inline = inline, inl_sat = Nothing }
+                 , inl_inline = inl_spec, inl_sat = Nothing }
   where
     matchinfo       = cvtRuleMatchInfo conlike
     opt_activation' = cvtActivation opt_activation
   where
     matchinfo       = cvtRuleMatchInfo conlike
     opt_activation' = cvtActivation opt_activation
@@ -408,6 +408,10 @@ cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation))
     cvtRuleMatchInfo False = FunLike
     cvtRuleMatchInfo True  = ConLike
 
     cvtRuleMatchInfo False = FunLike
     cvtRuleMatchInfo True  = ConLike
 
+    inl_spec | inline    = Inline
+             | otherwise = NoInline
+            -- Currently we have no way to say Inlinable
+
     cvtActivation Nothing | inline      = AlwaysActive
                           | otherwise   = NeverActive
     cvtActivation (Just (False, phase)) = ActiveBefore phase
     cvtActivation Nothing | inline      = AlwaysActive
                           | otherwise   = NeverActive
     cvtActivation (Just (False, phase)) = ActiveBefore phase
index 4d3f619..ec85995 100644 (file)
@@ -612,6 +612,19 @@ instance Binary InlinePragma where
            d <- get bh
            return (InlinePragma a b c d)
 
            d <- get bh
            return (InlinePragma a b c d)
 
+instance Binary InlineSpec where
+    put_ bh EmptyInlineSpec = putByte bh 0
+    put_ bh Inline          = putByte bh 1
+    put_ bh Inlinable       = putByte bh 2
+    put_ bh NoInline        = putByte bh 3
+
+    get bh = do h <- getByte bh
+                case h of
+                  0 -> return EmptyInlineSpec
+                  1 -> return Inline
+                  2 -> return Inlinable
+                  _ -> return NoInline
+
 instance Binary HsBang where
     put_ bh HsNoBang        = putByte bh 0
     put_ bh HsStrict        = putByte bh 1
 instance Binary HsBang where
     put_ bh HsNoBang        = putByte bh 0
     put_ bh HsStrict        = putByte bh 1
@@ -1188,8 +1201,9 @@ instance Binary IfaceInfoItem where
              _ -> do return HsNoCafRefs
 
 instance Binary IfaceUnfolding where
              _ -> do return HsNoCafRefs
 
 instance Binary IfaceUnfolding where
-    put_ bh (IfCoreUnfold e) = do
+    put_ bh (IfCoreUnfold s e) = do
        putByte bh 0
        putByte bh 0
+       put_ bh s
        put_ bh e
     put_ bh (IfInlineRule a b c d) = do
        putByte bh 1
        put_ bh e
     put_ bh (IfInlineRule a b c d) = do
        putByte bh 1
@@ -1210,8 +1224,9 @@ instance Binary IfaceUnfolding where
     get bh = do
        h <- getByte bh
        case h of
     get bh = do
        h <- getByte bh
        case h of
-         0 -> do e <- get bh
-                 return (IfCoreUnfold e)
+         0 -> do s <- get bh
+                 e <- get bh
+                 return (IfCoreUnfold s e)
          1 -> do a <- get bh
                  b <- get bh
                  c <- get bh
          1 -> do a <- get bh
                  b <- get bh
                  c <- get bh
index 282752b..c8348cb 100644 (file)
@@ -210,7 +210,8 @@ data IfaceInfoItem
 -- only later attached to the Id.  Partial reason: some are orphans.
 
 data IfaceUnfolding 
 -- only later attached to the Id.  Partial reason: some are orphans.
 
 data IfaceUnfolding 
-  = IfCoreUnfold IfaceExpr
+  = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding
+
   | IfCompulsory IfaceExpr     -- Only used for default methods, in fact
 
   | IfInlineRule Arity 
   | IfCompulsory IfaceExpr     -- Only used for default methods, in fact
 
   | IfInlineRule Arity 
@@ -688,11 +689,13 @@ instance Outputable IfaceInfoItem where
 
 instance Outputable IfaceUnfolding where
   ppr (IfCompulsory e)     = ptext (sLit "<compulsory>") <+> parens (ppr e)
 
 instance Outputable IfaceUnfolding where
   ppr (IfCompulsory e)     = ptext (sLit "<compulsory>") <+> parens (ppr e)
-  ppr (IfCoreUnfold e)     = parens (ppr e)
+  ppr (IfCoreUnfold s e)   = (if s then ptext (sLit "<stable>") else empty) <+> parens (ppr e)
   ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok),
                                        pprParendIfaceExpr e]
   ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok),
                                        pprParendIfaceExpr e]
-  ppr (IfWrapper a wkr)    = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a)
-  ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:") <+> brackets (pprWithCommas pprParendIfaceExpr ns)
+  ppr (IfWrapper a wkr)    = ptext (sLit "Worker:") <+> ppr wkr
+                             <+> parens (ptext (sLit "arity") <+> int a)
+  ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:")
+                             <+> brackets (pprWithCommas pprParendIfaceExpr ns)
 
 
 -- -----------------------------------------------------------------------------
 
 
 -- -----------------------------------------------------------------------------
@@ -810,7 +813,7 @@ freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
 freeNamesItem _              = emptyNameSet
 
 freeNamesIfUnfold :: IfaceUnfolding -> NameSet
 freeNamesItem _              = emptyNameSet
 
 freeNamesIfUnfold :: IfaceUnfolding -> NameSet
-freeNamesIfUnfold (IfCoreUnfold e)       = freeNamesIfExpr e
+freeNamesIfUnfold (IfCoreUnfold _ e)     = freeNamesIfExpr e
 freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e
 freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
 freeNamesIfUnfold (IfWrapper _ v)        = unitNameSet v
 freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e
 freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
 freeNamesIfUnfold (IfWrapper _ v)        = unitNameSet v
index 68c6cf1..fd8fbdb 100644 (file)
@@ -1535,21 +1535,23 @@ toIfaceIdInfo id_info
 
 --------------------------
 toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
 
 --------------------------
 toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
-toIfUnfolding lb unf@(CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
-                                    , uf_src = src, uf_guidance = guidance })
+toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
+                                , uf_src = src, uf_guidance = guidance })
   = Just $ HsUnfold lb $
     case src of
   = Just $ HsUnfold lb $
     case src of
-       InlineRule {}
+       InlineStable
           -> case guidance of
           -> case guidance of
-               UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok (toIfaceExpr rhs)
-               _other                     -> pprPanic "toIfUnfolding" (ppr unf)
+               UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs
+               _other                     -> IfCoreUnfold True if_rhs
        InlineWrapper w  -> IfWrapper arity (idName w)
        InlineWrapper w  -> IfWrapper arity (idName w)
-        InlineCompulsory -> IfCompulsory (toIfaceExpr rhs)
-        InlineRhs        -> IfCoreUnfold (toIfaceExpr rhs)
+        InlineCompulsory -> IfCompulsory if_rhs
+        InlineRhs        -> IfCoreUnfold False if_rhs
        -- Yes, even if guidance is UnfNever, expose the unfolding
        -- If we didn't want to expose the unfolding, TidyPgm would
        -- have stuck in NoUnfolding.  For supercompilation we want 
        -- to see that unfolding!
        -- Yes, even if guidance is UnfNever, expose the unfolding
        -- If we didn't want to expose the unfolding, TidyPgm would
        -- have stuck in NoUnfolding.  For supercompilation we want 
        -- to see that unfolding!
+  where
+    if_rhs = toIfaceExpr rhs
 
 toIfUnfolding lb (DFunUnfolding _ar _con ops)
   = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
 
 toIfUnfolding lb (DFunUnfolding _ar _con ops)
   = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
index fde3146..07b0b72 100644 (file)
@@ -1008,11 +1008,14 @@ tcIdInfo ignore_prags name ty info
 
 \begin{code}
 tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
 
 \begin{code}
 tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
-tcUnfolding name _ info (IfCoreUnfold if_expr)
+tcUnfolding name _ info (IfCoreUnfold stable if_expr)
   = do         { mb_expr <- tcPragExpr name if_expr
   = do         { mb_expr <- tcPragExpr name if_expr
+        ; let unf_src = if stable then InlineStable else InlineRhs
        ; return (case mb_expr of
        ; return (case mb_expr of
-                   Nothing -> NoUnfolding
-                   Just expr -> mkTopUnfolding is_bottoming expr) }
+                   Nothing   -> NoUnfolding
+                   Just expr -> mkUnfolding unf_src
+                                             True {- Top level -} 
+                                             is_bottoming expr) }
   where
      -- Strictness should occur before unfolding!
     is_bottoming = case strictnessInfo info of
   where
      -- Strictness should occur before unfolding!
     is_bottoming = case strictnessInfo info of
@@ -1029,7 +1032,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 InlineRule expr arity 
+                   Just expr -> mkCoreUnfolding True InlineStable expr arity 
                                                  (UnfWhen unsat_ok boring_ok))
     }
 
                                                  (UnfWhen unsat_ok boring_ok))
     }
 
index 8ce4dcd..7d04563 100644 (file)
@@ -725,7 +725,7 @@ addExternal expose_all id = (new_needed_ids, show_unfold)
        =  expose_all        -- 'expose_all' says to expose all 
                             -- unfoldings willy-nilly
 
        =  expose_all        -- 'expose_all' says to expose all 
                             -- unfoldings willy-nilly
 
-       || isInlineRuleSource unf_source             -- Always expose things whose 
+       || isStableSource unf_source         -- Always expose things whose 
                                                     -- source is an inline rule
 
        || not (bottoming_fn     -- No need to inline bottom functions
                                                     -- source is an inline rule
 
        || not (bottoming_fn     -- No need to inline bottom functions
@@ -1098,7 +1098,7 @@ tidyUnfolding tidy_env _ _ (DFunUnfolding ar con ids)
   = DFunUnfolding ar con (map (tidyExpr tidy_env) ids)
 tidyUnfolding tidy_env tidy_rhs strict_sig
               unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
   = DFunUnfolding ar con (map (tidyExpr tidy_env) ids)
 tidyUnfolding tidy_env tidy_rhs strict_sig
               unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
-  | isInlineRuleSource src
+  | isStableSource src
   = unf { uf_tmpl = tidyExpr tidy_env unf_rhs,            -- Preserves OccInfo
          uf_src  = tidyInl tidy_env src }
   | otherwise
   = unf { uf_tmpl = tidyExpr tidy_env unf_rhs,            -- Preserves OccInfo
          uf_src  = tidyInl tidy_env src }
   | otherwise
index cadd56d..0fa3256 100644 (file)
@@ -66,6 +66,7 @@ import UniqFM
 import DynFlags
 import Module
 import Ctype
 import DynFlags
 import Module
 import Ctype
+import BasicTypes      ( InlineSpec(..), RuleMatchInfo(..) )
 import Util            ( readRational )
 
 import Control.Monad
 import Util            ( readRational )
 
 import Control.Monad
@@ -462,8 +463,7 @@ data Token
   | ITusing
 
        -- Pragmas
   | ITusing
 
        -- Pragmas
-  | ITinline_prag Bool         -- True <=> INLINE, False <=> NOINLINE
-  | ITinline_conlike_prag Bool  -- same
+  | ITinline_prag InlineSpec RuleMatchInfo
   | ITspec_prag                        -- SPECIALISE   
   | ITspec_inline_prag Bool    -- SPECIALISE INLINE (or NOINLINE)
   | ITsource_prag
   | ITspec_prag                        -- SPECIALISE   
   | ITspec_inline_prag Bool    -- SPECIALISE INLINE (or NOINLINE)
   | ITsource_prag
@@ -2216,8 +2216,9 @@ ignoredPrags = Map.fromList (map ignored pragmas)
                      pragmas = options_pragmas ++ ["cfiles", "contract"]
 
 oneWordPrags = Map.fromList([("rules", rulePrag),
                      pragmas = options_pragmas ++ ["cfiles", "contract"]
 
 oneWordPrags = Map.fromList([("rules", rulePrag),
-                           ("inline", token (ITinline_prag True)),
-                           ("notinline", token (ITinline_prag False)),
+                           ("inline", token (ITinline_prag Inline FunLike)),
+                           ("inlinable", token (ITinline_prag Inlinable FunLike)),
+                           ("notinline", token (ITinline_prag NoInline FunLike)),
                            ("specialize", token ITspec_prag),
                            ("source", token ITsource_prag),
                            ("warning", token ITwarning_prag),
                            ("specialize", token ITspec_prag),
                            ("source", token ITsource_prag),
                            ("warning", token ITwarning_prag),
@@ -2228,8 +2229,8 @@ oneWordPrags = Map.fromList([("rules", rulePrag),
                            ("unpack", token ITunpack_prag),
                            ("ann", token ITann_prag)])
 
                            ("unpack", token ITunpack_prag),
                            ("ann", token ITann_prag)])
 
-twoWordPrags = Map.fromList([("inline conlike", token (ITinline_conlike_prag True)),
-                             ("notinline conlike", token (ITinline_conlike_prag False)),
+twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
+                             ("notinline conlike", token (ITinline_prag NoInline ConLike)),
                              ("specialize inline", token (ITspec_inline_prag True)),
                              ("specialize notinline", token (ITspec_inline_prag False))])
 
                              ("specialize inline", token (ITspec_inline_prag True)),
                              ("specialize notinline", token (ITspec_inline_prag False))])
 
index e78b1ca..7ab7c44 100644 (file)
@@ -56,8 +56,7 @@ import StaticFlags    ( opt_SccProfilingOn, opt_Hpc )
 import Type            ( Kind, liftedTypeKind, unliftedTypeKind )
 import Coercion                ( mkArrowKind )
 import Class           ( FunDep )
 import Type            ( Kind, liftedTypeKind, unliftedTypeKind )
 import Coercion                ( mkArrowKind )
 import Class           ( FunDep )
-import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
-                         Activation(..), RuleMatchInfo(..), defaultInlinePragma )
+import BasicTypes
 import DynFlags
 import OrdList
 import HaddockUtils
 import DynFlags
 import OrdList
 import HaddockUtils
@@ -261,8 +260,7 @@ incorrect.
  'by'       { L _ ITby }        -- for list transform extension
  'using'    { L _ ITusing }     -- for list transform extension
 
  'by'       { L _ ITby }        -- for list transform extension
  'using'    { L _ ITusing }     -- for list transform extension
 
- '{-# INLINE'            { L _ (ITinline_prag _) }
- '{-# INLINE_CONLIKE'     { L _ (ITinline_conlike_prag _) }
+ '{-# INLINE'            { L _ (ITinline_prag _ _) }
  '{-# SPECIALISE'        { L _ ITspec_prag }
  '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _) }
  '{-# SOURCE'     { L _ ITsource_prag }
  '{-# SPECIALISE'        { L _ ITspec_prag }
  '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _) }
  '{-# SOURCE'     { L _ ITsource_prag }
@@ -1238,14 +1236,12 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
        | infix prec ops        { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
                                             | n <- unLoc $3 ] }
        | '{-# INLINE'   activation qvar '#-}'        
        | infix prec ops        { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
                                             | n <- unLoc $3 ] }
        | '{-# INLINE'   activation qvar '#-}'        
-               { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 FunLike (getINLINE $1)))) }
-        | '{-# INLINE_CONLIKE' activation qvar '#-}'
-                { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 ConLike (getINLINE_CONLIKE $1)))) }
+               { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
        | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
                { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlinePragma) 
                                            | t <- $4] }
        | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
        | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
                { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlinePragma) 
                                            | t <- $4] }
        | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
-               { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma $2 FunLike (getSPEC_INLINE $1)))
+               { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2))
                                            | t <- $5] }
        | '{-# SPECIALISE' 'instance' inst_type '#-}'
                { LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
                                            | t <- $5] }
        | '{-# SPECIALISE' 'instance' inst_type '#-}'
                { LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
@@ -1988,9 +1984,9 @@ getPRIMWORD       (L _ (ITprimword x)) = x
 getPRIMFLOAT   (L _ (ITprimfloat  x)) = x
 getPRIMDOUBLE  (L _ (ITprimdouble x)) = x
 getTH_ID_SPLICE (L _ (ITidEscape x)) = x
 getPRIMFLOAT   (L _ (ITprimfloat  x)) = x
 getPRIMDOUBLE  (L _ (ITprimdouble x)) = x
 getTH_ID_SPLICE (L _ (ITidEscape x)) = x
-getINLINE      (L _ (ITinline_prag b)) = b
-getINLINE_CONLIKE (L _ (ITinline_conlike_prag b)) = b
-getSPEC_INLINE (L _ (ITspec_inline_prag b)) = b
+getINLINE      (L _ (ITinline_prag inl conl)) = (inl,conl)
+getSPEC_INLINE (L _ (ITspec_inline_prag True))  = (Inline,  FunLike)
+getSPEC_INLINE (L _ (ITspec_inline_prag False)) = (NoInline,FunLike)
 
 getDOCNEXT (L _ (ITdocCommentNext x)) = x
 getDOCPREV (L _ (ITdocCommentPrev x)) = x
 
 getDOCNEXT (L _ (ITdocCommentNext x)) = x
 getDOCPREV (L _ (ITdocCommentPrev x)) = x
index 7d806ed..548b111 100644 (file)
@@ -55,7 +55,7 @@ import TypeRep          ( Kind )
 import RdrName         ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
                          isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
 import BasicTypes      ( maxPrecedence, Activation(..), RuleMatchInfo,
 import RdrName         ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
                          isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
 import BasicTypes      ( maxPrecedence, Activation(..), RuleMatchInfo,
-                          InlinePragma(..) )
+                          InlinePragma(..), InlineSpec(..) )
 import Lexer
 import TysWiredIn      ( unitTyCon ) 
 import ForeignCall
 import Lexer
 import TysWiredIn      ( unitTyCon ) 
 import ForeignCall
@@ -937,9 +937,9 @@ mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 
 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 
-mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma
+mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
 -- The Maybe is because the user can omit the activation spec (and usually does)
 -- The Maybe is because the user can omit the activation spec (and usually does)
-mkInlinePragma mb_act match_info inl 
+mkInlinePragma (inl, match_info) mb_act
   = InlinePragma { inl_inline = inl
                  , inl_sat    = Nothing
                  , inl_act    = act
   = InlinePragma { inl_inline = inl
                  , inl_sat    = Nothing
                  , inl_act    = act
@@ -947,11 +947,10 @@ mkInlinePragma mb_act match_info inl
   where
     act = case mb_act of
             Just act -> act
   where
     act = case mb_act of
             Just act -> act
-            Nothing | inl       -> AlwaysActive
-                    | otherwise -> NeverActive
-        -- If no specific phase is given then:
-       --   NOINLINE => NeverActive
-        --   INLINE   => Active
+            Nothing  -> -- No phase specified
+                        case inl of
+                          NoInline -> NeverActive
+                          _other   -> AlwaysActive
 
 -----------------------------------------------------------------------------
 -- utilities for foreign declarations
 
 -----------------------------------------------------------------------------
 -- utilities for foreign declarations
index a37b5f1..3dca9a8 100644 (file)
@@ -537,7 +537,7 @@ reOrderCycle depth (bind : binds) pairs
         | isDFunId bndr = 9   -- Never choose a DFun as a loop breaker
                              -- Note [DFuns should not be loop breakers]
 
         | isDFunId bndr = 9   -- Never choose a DFun as a loop breaker
                              -- Note [DFuns should not be loop breakers]
 
-        | Just (inl_source, _) <- isInlineRule_maybe (idUnfolding bndr)
+        | Just (inl_source, _) <- isStableUnfolding_maybe (idUnfolding bndr)
        = case inl_source of
             InlineWrapper {} -> 10  -- Note [INLINE pragmas]
             _other           ->  3  -- Data structures are more important than this
        = case inl_source of
             InlineWrapper {} -> 10  -- Note [INLINE pragmas]
             _other           ->  3  -- Data structures are more important than this
index ef0c7f2..23874bf 100644 (file)
@@ -859,7 +859,7 @@ abstractVars dest_lvl (_, lvl_env, _, id_env) fvs
 
        -- We are going to lambda-abstract, so nuke any IdInfo,
        -- and add the tyvars of the Id (if necessary)
 
        -- We are going to lambda-abstract, so nuke any IdInfo,
        -- and add the tyvars of the Id (if necessary)
-    zap v | isId v = WARN( isInlineRule (idUnfolding v) ||
+    zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||
                           not (isEmptySpecInfo (idSpecialisation v)),
                           text "absVarsOf: discarding info on" <+> ppr v )
                     setIdInfo v vanillaIdInfo
                           not (isEmptySpecInfo (idSpecialisation v)),
                           text "absVarsOf: discarding info on" <+> ppr v )
                     setIdInfo v vanillaIdInfo
index 0a1fdd2..5d8e0a2 100644 (file)
@@ -28,8 +28,9 @@ import CoreMonad      ( SimplifierSwitch(..), Tick(..) )
 import CoreSyn
 import Demand           ( isStrictDmd, splitStrictSig )
 import PprCore          ( pprParendExpr, pprCoreExpr )
 import CoreSyn
 import Demand           ( isStrictDmd, splitStrictSig )
 import PprCore          ( pprParendExpr, pprCoreExpr )
-import CoreUnfold       ( mkUnfolding, mkCoreUnfolding, mkInlineRule, 
-                          exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
+import CoreUnfold       ( mkUnfolding, mkCoreUnfolding
+                        , mkInlineUnfolding, mkSimpleUnfolding
+                        , exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
 import CoreUtils
 import qualified CoreSubst
 import CoreArity       ( exprArity )
 import CoreUtils
 import qualified CoreSubst
 import CoreArity       ( exprArity )
@@ -713,7 +714,7 @@ simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops)
 simplUnfolding env top_lvl id _ _ 
     (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
                    , uf_src = src, uf_guidance = guide })
 simplUnfolding env top_lvl id _ _ 
     (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
                    , uf_src = src, uf_guidance = guide })
-  | isInlineRuleSource 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) }
   = 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) }
@@ -724,7 +725,7 @@ simplUnfolding env top_lvl id _ _
                       -- See Note [Simplifying gently inside InlineRules] in SimplUtils
 
 simplUnfolding _ top_lvl id _occ_info new_rhs _
                       -- See Note [Simplifying gently inside InlineRules] in SimplUtils
 
 simplUnfolding _ top_lvl id _occ_info new_rhs _
-  = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs)
+  = return (mkUnfolding InlineRhs (isTopLevel top_lvl) (isBottomingId id) new_rhs)
   -- We make an  unfolding *even for loop-breakers*.
   -- Reason: (a) It might be useful to know that they are WHNF
   --        (b) In TidyPgm we currently assume that, if we want to
   -- We make an  unfolding *even for loop-breakers*.
   -- Reason: (a) It might be useful to know that they are WHNF
   --        (b) In TidyPgm we currently assume that, if we want to
@@ -1789,7 +1790,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
 
 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
 addBinderUnfolding env bndr rhs
 
 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
 addBinderUnfolding env bndr rhs
-  = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs)
+  = modifyInScope env (bndr `setIdUnfolding` mkSimpleUnfolding rhs)
 
 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
 addBinderOtherCon env bndr cons
 
 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
 addBinderOtherCon env bndr cons
@@ -2016,7 +2017,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs')
                      DataAlt dc -> setIdUnfolding case_bndr unf
                          where
                                 -- See Note [Case binders and join points]
                      DataAlt dc -> setIdUnfolding case_bndr unf
                          where
                                 -- See Note [Case binders and join points]
-                            unf = mkInlineRule rhs Nothing
+                            unf = mkInlineUnfolding Nothing rhs
                             rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
                                                ++ varsToCoreExprs bndrs')
 
                             rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
                                                ++ varsToCoreExprs bndrs')
 
index 2d0b383..47a4f05 100644 (file)
@@ -11,7 +11,7 @@ module Specialise ( specProgram ) where
 import Id
 import TcType
 import CoreSubst 
 import Id
 import TcType
 import CoreSubst 
-import CoreUnfold      ( mkUnfolding, mkInlineRule )
+import CoreUnfold      ( mkSimpleUnfolding, mkInlineUnfolding )
 import VarSet
 import VarEnv
 import CoreSyn
 import VarSet
 import VarEnv
 import CoreSyn
@@ -706,7 +706,7 @@ specCase subst scrut' case_bndr [(con, args, rhs)]
          loc  = getSrcSpan name
 
     add_unf sc_flt sc_rhs  -- Sole purpose: make sc_flt respond True to interestingDictId
          loc  = getSrcSpan name
 
     add_unf sc_flt sc_rhs  -- Sole purpose: make sc_flt respond True to interestingDictId
-      = setIdUnfolding sc_flt (mkUnfolding False False sc_rhs)
+      = setIdUnfolding sc_flt (mkSimpleUnfolding sc_rhs)
 
     arg_set = mkVarSet args'
     is_flt_sc_arg var =  isId var
 
     arg_set = mkVarSet args'
     is_flt_sc_arg var =  isId var
@@ -908,7 +908,7 @@ specDefn subst body_uds fn rhs
        -- Figure out whether the function has an INLINE pragma
        -- See Note [Inline specialisations]
     fn_has_inline_rule :: Maybe Bool   -- Derive sat-flag from existing thing
        -- Figure out whether the function has an INLINE pragma
        -- See Note [Inline specialisations]
     fn_has_inline_rule :: Maybe Bool   -- Derive sat-flag from existing thing
-    fn_has_inline_rule = case isInlineRule_maybe fn_unf of
+    fn_has_inline_rule = case isStableUnfolding_maybe fn_unf of
                            Just (_,sat) -> Just sat
                           Nothing      -> Nothing
 
                            Just (_,sat) -> Just sat
                           Nothing      -> Nothing
 
@@ -1015,7 +1015,7 @@ specDefn subst body_uds fn rhs
                  = let 
                        mb_spec_arity = if sat then Just spec_arity else Nothing
                     in 
                  = let 
                        mb_spec_arity = if sat then Just spec_arity else Nothing
                     in 
-                    spec_f_w_arity `setIdUnfolding` mkInlineRule spec_rhs mb_spec_arity
+                    spec_f_w_arity `setIdUnfolding` mkInlineUnfolding mb_spec_arity spec_rhs
                  | otherwise 
                  = spec_f_w_arity
 
                  | otherwise 
                  = spec_f_w_arity
 
@@ -1048,7 +1048,7 @@ bindAuxiliaryDicts subst triples = go subst [] triples
 
       | otherwise        = go subst_w_unf (NonRec dx_id dx : binds) pairs
       where
 
       | otherwise        = go subst_w_unf (NonRec dx_id dx : binds) pairs
       where
-        dx_id1 = dx_id `setIdUnfolding` mkUnfolding False False dx
+        dx_id1 = dx_id `setIdUnfolding` mkSimpleUnfolding dx
        subst_w_unf = extendIdSubst subst d (Var dx_id1)
                     -- Important!  We're going to substitute dx_id1 for d
             -- and we want it to look "interesting", else we won't gather *any*
        subst_w_unf = extendIdSubst subst d (Var dx_id1)
                     -- Important!  We're going to substitute dx_id1 for d
             -- and we want it to look "interesting", else we won't gather *any*
index 7a56c33..d329b5a 100644 (file)
@@ -7,20 +7,16 @@
 module WorkWrap ( wwTopBinds, mkWrapper ) where
 
 import CoreSyn
 module WorkWrap ( wwTopBinds, mkWrapper ) where
 
 import CoreSyn
-import CoreUnfold      ( certainlyWillInline, mkInlineRule, mkWwInlineRule )
+import CoreUnfold      ( certainlyWillInline, mkInlineUnfolding, mkWwInlineRule )
 import CoreUtils       ( exprType, exprIsHNF )
 import CoreArity       ( exprArity )
 import Var
 import Id
 import Type            ( Type )
 import IdInfo
 import CoreUtils       ( exprType, exprIsHNF )
 import CoreArity       ( exprArity )
 import Var
 import Id
 import Type            ( Type )
 import IdInfo
-import Demand           ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), 
-                         Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent
-                       )
+import Demand
 import UniqSupply
 import UniqSupply
-import BasicTypes      ( RecFlag(..), isNonRec, isNeverActive,
-                          Activation(..), InlinePragma(..), 
-                         inlinePragmaActivation, inlinePragmaRuleMatchInfo )
+import BasicTypes
 import VarEnv          ( isEmptyVarEnv )
 import Maybes          ( orElse )
 import WwLib
 import VarEnv          ( isEmptyVarEnv )
 import Maybes          ( orElse )
 import WwLib
@@ -276,7 +272,7 @@ checkSize fn_id rhs thing_inside
   | otherwise = thing_inside
   where
     unfolding   = idUnfolding fn_id
   | otherwise = thing_inside
   where
     unfolding   = idUnfolding fn_id
-    inline_rule = mkInlineRule rhs Nothing
+    inline_rule = mkInlineUnfolding Nothing rhs
 
 ---------------------
 splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var
 
 ---------------------
 splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var
@@ -314,7 +310,7 @@ splitFun fn_id fn_info wrap_dmds res_info rhs
                                 -- arity is consistent with the demand type goes through
 
        wrap_rhs  = wrap_fn work_id
                                 -- arity is consistent with the demand type goes through
 
        wrap_rhs  = wrap_fn work_id
-       wrap_prag = InlinePragma { inl_inline = True
+       wrap_prag = InlinePragma { inl_inline = Inline
                                  , inl_sat    = Nothing
                                  , inl_act    = ActiveAfter 0
                                  , inl_rule   = rule_match_info }
                                  , inl_sat    = Nothing
                                  , inl_act    = ActiveAfter 0
                                  , inl_rule   = rule_match_info }
index a296e89..8e04833 100644 (file)
@@ -15,7 +15,7 @@ import Vectorise.Monad
 import HscTypes hiding      ( MonadThings(..) )
 import Module               ( PackageId )
 import CoreSyn
 import HscTypes hiding      ( MonadThings(..) )
 import Module               ( PackageId )
 import CoreSyn
-import CoreUnfold           ( mkInlineRule )
+import CoreUnfold           ( mkInlineUnfolding )
 import CoreFVs
 import CoreMonad            ( CoreM, getHscEnv )
 import FamInstEnv           ( extendFamInstEnvList )
 import CoreFVs
 import CoreMonad            ( CoreM, getHscEnv )
 import FamInstEnv           ( extendFamInstEnvList )
@@ -177,7 +177,7 @@ vectTopBinder var inline expr
       return var'
   where
     unfolding = case inline of
       return var'
   where
     unfolding = case inline of
-                  Inline arity -> mkInlineRule expr (Just arity)
+                  Inline arity -> mkInlineUnfolding (Just arity) expr
                   DontInline   -> noUnfolding
 
 
                   DontInline   -> noUnfolding
 
 
index 7831c93..42efe37 100644 (file)
@@ -22,7 +22,7 @@ import Var
 import VarEnv
 import VarSet
 import Id
 import VarEnv
 import VarSet
 import Id
-import BasicTypes
+import BasicTypes( isLoopBreaker )
 import Literal
 import TysWiredIn
 import TysPrim
 import Literal
 import TysWiredIn
 import TysPrim
index 8e26ed9..06bd789 100644 (file)
@@ -182,7 +182,7 @@ vectDataConWorkers orig_tc vect_tc arr_tc
 
           raw_worker <- cloneId mkVectOcc orig_worker (exprType body)
           let vect_worker = raw_worker `setIdUnfolding`
 
           raw_worker <- cloneId mkVectOcc orig_worker (exprType body)
           let vect_worker = raw_worker `setIdUnfolding`
-                              mkInlineRule body (Just arity)
+                              mkInlineUnfolding (Just arity) body
           defGlobalVar orig_worker vect_worker
           return (vect_worker, body)
       where
           defGlobalVar orig_worker vect_worker
           return (vect_worker, body)
       where
index ef5c8d5..d3d2213 100644 (file)
@@ -56,7 +56,7 @@ buildPADict vect_tc prepr_tc arr_tc repr
           let body = mkLams (tvs ++ args) expr
           raw_var <- newExportedVar (method_name name) (exprType body)
           let var = raw_var
           let body = mkLams (tvs ++ args) expr
           raw_var <- newExportedVar (method_name name) (exprType body)
           let var = raw_var
-                      `setIdUnfolding` mkInlineRule body (Just (length args))
+                      `setIdUnfolding` mkInlineUnfolding (Just (length args)) body
                       `setInlinePragma` alwaysInlinePragma
           hoistBinding var body
           return var
                       `setInlinePragma` alwaysInlinePragma
           hoistBinding var body
           return var
index b70ecb4..6b8688c 100644 (file)
@@ -24,7 +24,7 @@ import TyCon
 import DataCon
 import MkId
 import TysWiredIn
 import DataCon
 import MkId
 import TysWiredIn
-import BasicTypes
+import BasicTypes( Boxity(..) )
 import FastString
 
 
 import FastString
 
 
index 9cce416..12b1b6f 100644 (file)
@@ -22,7 +22,7 @@ import CoreUnfold
 import Type
 import Var
 import Id
 import Type
 import Var
 import Id
-import BasicTypes
+import BasicTypes( Arity )
 import FastString
 import Control.Monad
 
 import FastString
 import Control.Monad
 
@@ -58,7 +58,7 @@ hoistExpr fs expr inl
   where
     mk_inline var = case inl of
                       Inline arity -> var `setIdUnfolding`
   where
     mk_inline var = case inl of
                       Inline arity -> var `setIdUnfolding`
-                                      mkInlineRule expr (Just arity)
+                                      mkInlineUnfolding (Just arity) expr
                       DontInline   -> var
 
 
                       DontInline   -> var