Add the notion of "constructor-like" Ids for rule-matching
authorsimonpj@microsoft.com <unknown>
Wed, 18 Mar 2009 10:59:11 +0000 (10:59 +0000)
committersimonpj@microsoft.com <unknown>
Wed, 18 Mar 2009 10:59:11 +0000 (10:59 +0000)
This patch adds an optional CONLIKE modifier to INLINE/NOINLINE pragmas,
   {-# NOINLINE CONLIKE [1] f #-}
The effect is to allow applications of 'f' to be expanded in a potential
rule match.  Example
  {-# RULE "r/f" forall v. r (f v) = f (v+1) #-}

Consider the term
     let x = f v in ..x...x...(r x)...
Normally the (r x) would not match the rule, because GHC would be scared
about duplicating the redex (f v). However the CONLIKE modifier says to
treat 'f' like a constructor in this situation, and "look through" the
unfolding for x.  So (r x) fires, yielding (f (v+1)).

The main changes are:
  - Syntax

  - The inlinePragInfo field of an IdInfo has a RuleMatchInfo
    component, which records whether or not the Id is CONLIKE.
    Of course, this needs to be serialised in interface files too.

  - The occurrence analyser (OccAnal) and simplifier (Simplify) treat
    CONLIKE thing like constructors, by ANF-ing them

  - New function coreUtils.exprIsExpandable is like exprIsCheap, but
    additionally spots applications of CONLIKE functions

  - A CoreUnfolding has a field that caches exprIsExpandable

  - The rule matcher consults this field.  See
    Note [Expanding variables] in Rules.lhs.

On the way I fixed a lurking variable bug in the way variables are
expanded.  See Note [Do not expand locally-bound variables] in
Rule.lhs.  I also did a bit of reformatting and refactoring in
Rules.lhs, so the module has more lines changed than are really
different.

26 files changed:
compiler/basicTypes/BasicTypes.lhs
compiler/basicTypes/Id.lhs
compiler/basicTypes/IdInfo.lhs
compiler/coreSyn/CoreSyn.lhs
compiler/coreSyn/CoreUnfold.lhs
compiler/coreSyn/CoreUtils.lhs
compiler/coreSyn/PprCore.lhs
compiler/deSugar/DsBinds.lhs
compiler/deSugar/DsForeign.lhs
compiler/iface/BinIface.hs
compiler/iface/IfaceSyn.lhs
compiler/iface/MkIface.lhs
compiler/main/TidyPgm.lhs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs
compiler/simplCore/CSE.lhs
compiler/simplCore/OccurAnal.lhs
compiler/simplCore/SimplEnv.lhs
compiler/simplCore/SimplUtils.lhs
compiler/simplCore/Simplify.lhs
compiler/specialise/Rules.lhs
compiler/specialise/Specialise.lhs
compiler/stranal/DmdAnal.lhs
compiler/stranal/WorkWrap.lhs
compiler/typecheck/TcInstDcls.lhs

index 04ed8fa..fad6533 100644 (file)
@@ -55,6 +55,10 @@ module BasicTypes(
 
        CompilerPhase, 
        Activation(..), isActive, isNeverActive, isAlwaysActive,
+        RuleMatchInfo(..), isConLike, isFunLike,
+        InlinePragma(..), defaultInlinePragma, isDefaultInlinePragma,
+        inlinePragmaActivation, inlinePragmaRuleMatchInfo,
+        setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
        InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec,
 
        SuccessFlag(..), succeeded, failed, successIf
@@ -580,35 +584,94 @@ data Activation = NeverActive
                | ActiveAfter CompilerPhase     -- Active in this phase and later
                deriving( Eq )                  -- Eq used in comparing rules in HsDecls
 
+data RuleMatchInfo = ConLike
+                   | FunLike
+                   deriving( Eq )
+
+isConLike :: RuleMatchInfo -> Bool
+isConLike ConLike = True
+isConLike _            = False
+
+isFunLike :: RuleMatchInfo -> Bool
+isFunLike FunLike = True
+isFunLike _            = False
+
+data InlinePragma
+  = InlinePragma
+      Activation        -- Says during which phases inlining is allowed
+      RuleMatchInfo     -- Should the function be treated like a constructor?
+  deriving( Eq )
+
+defaultInlinePragma :: InlinePragma
+defaultInlinePragma = InlinePragma AlwaysActive FunLike
+
+isDefaultInlinePragma :: InlinePragma -> Bool
+isDefaultInlinePragma (InlinePragma activation match_info)
+  = isAlwaysActive activation && isFunLike match_info
+
+inlinePragmaActivation :: InlinePragma -> Activation
+inlinePragmaActivation (InlinePragma activation _) = activation
+
+inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo
+inlinePragmaRuleMatchInfo (InlinePragma _ info) = info
+
+setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma
+setInlinePragmaActivation (InlinePragma _ info) activation
+  = InlinePragma activation info
+
+setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
+setInlinePragmaRuleMatchInfo (InlinePragma activation _) info
+  = InlinePragma activation info
+
 data InlineSpec
-  = Inline 
-       Activation      -- Says during which phases inlining is allowed
+  = Inline
+        InlinePragma
        Bool            -- True  <=> INLINE
                        -- False <=> NOINLINE
   deriving( Eq )
 
-defaultInlineSpec, alwaysInlineSpec, neverInlineSpec :: InlineSpec
+defaultInlineSpec :: InlineSpec
+alwaysInlineSpec, neverInlineSpec :: RuleMatchInfo -> InlineSpec
 
-defaultInlineSpec = Inline AlwaysActive False  -- Inlining is OK, but not forced
-alwaysInlineSpec  = Inline AlwaysActive True   -- INLINE always
-neverInlineSpec   = Inline NeverActive  False  -- NOINLINE 
+defaultInlineSpec = Inline defaultInlinePragma False
+                                                -- Inlining is OK, but not forced
+alwaysInlineSpec match_info
+                = Inline (InlinePragma AlwaysActive match_info) True
+                                                -- INLINE always
+neverInlineSpec match_info
+                = Inline (InlinePragma NeverActive  match_info) False
+                                                -- NOINLINE
 
 instance Outputable Activation where
    ppr NeverActive      = ptext (sLit "NEVER")
    ppr AlwaysActive     = ptext (sLit "ALWAYS")
    ppr (ActiveBefore n) = brackets (char '~' <> int n)
    ppr (ActiveAfter n)  = brackets (int n)
+
+instance Outputable RuleMatchInfo where
+   ppr ConLike = ptext (sLit "CONLIKE")
+   ppr FunLike = ptext (sLit "FUNLIKE")
+
+instance Outputable InlinePragma where
+  ppr (InlinePragma activation FunLike)
+       = ppr activation
+  ppr (InlinePragma activation match_info)
+       = ppr match_info <+> ppr activation
     
 instance Outputable InlineSpec where
-   ppr (Inline act is_inline)  
+   ppr (Inline (InlinePragma act match_info) is_inline)  
        | is_inline = ptext (sLit "INLINE")
-                     <> case act of
-                           AlwaysActive -> empty
-                           _            -> ppr act
+                      <+> ppr_match_info
+                     <+> case act of
+                            AlwaysActive -> empty
+                            _            -> ppr act
        | otherwise = ptext (sLit "NOINLINE")
-                     <> case act of
-                           NeverActive  -> empty
-                           _            -> ppr act
+                      <+> ppr_match_info
+                     <+> case act of
+                            NeverActive  -> empty
+                            _            -> ppr act
+     where
+       ppr_match_info = if isFunLike match_info then empty else ppr match_info
 
 isActive :: CompilerPhase -> Activation -> Bool
 isActive _ NeverActive      = False
index 676d6cf..2f5e93c 100644 (file)
@@ -53,12 +53,13 @@ module Id (
        isPrimOpId, isPrimOpId_maybe, 
        isFCallId, isFCallId_maybe,
        isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
-       isBottomingId, idIsFrom,
+        isConLikeId, isBottomingId, idIsFrom,
         isTickBoxOp, isTickBoxOp_maybe,
        hasNoBinding, 
 
        -- ** Inline pragma stuff
-       idInlinePragma, setInlinePragma, modifyInlinePragma, 
+       idInlinePragma, setInlinePragma, modifyInlinePragma,
+        idInlineActivation, setInlineActivation, idRuleMatchInfo,
 
        -- ** One-shot lambdas
        isOneShotBndr, isOneShotLambda, isStateHackType,
@@ -599,14 +600,26 @@ The inline pragma tells us to be very keen to inline this Id, but it's still
 OK not to if optimisation is switched off.
 
 \begin{code}
-idInlinePragma :: Id -> InlinePragInfo
+idInlinePragma :: Id -> InlinePragma
 idInlinePragma id = inlinePragInfo (idInfo id)
 
-setInlinePragma :: Id -> InlinePragInfo -> Id
+setInlinePragma :: Id -> InlinePragma -> Id
 setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id
 
-modifyInlinePragma :: Id -> (InlinePragInfo -> InlinePragInfo) -> Id
+modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id
 modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id
+
+idInlineActivation :: Id -> Activation
+idInlineActivation id = inlinePragmaActivation (idInlinePragma id)
+
+setInlineActivation :: Id -> Activation -> Id
+setInlineActivation id act = modifyInlinePragma id (\(InlinePragma _ match_info) -> InlinePragma act match_info)
+
+idRuleMatchInfo :: Id -> RuleMatchInfo
+idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id)
+
+isConLikeId :: Id -> Bool
+isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id)
 \end{code}
 
 
index 07cc181..9889dbc 100644 (file)
@@ -329,7 +329,7 @@ data IdInfo
        unfoldingInfo   :: Unfolding,           -- ^ The 'Id's unfolding
        cafInfo         :: CafInfo,             -- ^ 'Id' CAF info
         lbvarInfo      :: LBVarInfo,           -- ^ Info about a lambda-bound variable, if the 'Id' is one
-       inlinePragInfo  :: InlinePragInfo,      -- ^ Any inline pragma atached to the 'Id'
+       inlinePragInfo  :: InlinePragma,        -- ^ Any inline pragma atached to the 'Id'
        occInfo         :: OccInfo,             -- ^ How the 'Id' occurs in the program
 
        newStrictnessInfo :: Maybe StrictSig,   -- ^ Id strictness information. Reason for Maybe: 
@@ -378,7 +378,7 @@ setWorkerInfo :: IdInfo -> WorkerInfo -> IdInfo
 setWorkerInfo     info wk = wk `seq` info { workerInfo = wk }
 setSpecInfo :: IdInfo -> SpecInfo -> IdInfo
 setSpecInfo      info sp = sp `seq` info { specInfo = sp }
-setInlinePragInfo :: IdInfo -> InlinePragInfo -> IdInfo
+setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo
 setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
 setOccInfo :: IdInfo -> OccInfo -> IdInfo
 setOccInfo       info oc = oc `seq` info { occInfo = oc }
@@ -434,7 +434,7 @@ vanillaIdInfo
            workerInfo          = NoWorker,
            unfoldingInfo       = noUnfolding,
            lbvarInfo           = NoLBVarInfo,
-           inlinePragInfo      = AlwaysActive,
+           inlinePragInfo      = defaultInlinePragma,
            occInfo             = NoOccInfo,
            newDemandInfo       = Nothing,
            newStrictnessInfo   = Nothing
@@ -493,7 +493,7 @@ ppArityInfo n = hsep [ptext (sLit "Arity"), int n]
 --
 -- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves
 -- entirely as a way to inhibit inlining until we want it
-type InlinePragInfo = Activation
+type InlinePragInfo = InlinePragma
 \end{code}
 
 
index 1b3a9d7..4d8f3cb 100644 (file)
@@ -42,7 +42,8 @@ module CoreSyn (
        
        -- ** Predicates and deconstruction on 'Unfolding'
        unfoldingTemplate, maybeUnfoldingTemplate, otherCons, 
-       isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
+       isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
+        isExpandableUnfolding, isCompulsoryUnfolding,
        hasUnfolding, hasSomeUnfolding, neverUnfold,
 
        -- * Strictness
@@ -412,6 +413,7 @@ data Unfolding
                Bool
                Bool
                Bool
+                Bool
                UnfoldingGuidance
   -- ^ An unfolding with redundant cached information. Parameters:
   --
@@ -455,8 +457,8 @@ mkOtherCon :: [AltCon] -> Unfolding
 mkOtherCon = OtherCon
 
 seqUnfolding :: Unfolding -> ()
-seqUnfolding (CoreUnfolding e top b1 b2 g)
-  = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
+seqUnfolding (CoreUnfolding e top b1 b2 b3 g)
+  = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` seqGuidance g
 seqUnfolding _ = ()
 
 seqGuidance :: UnfoldingGuidance -> ()
@@ -467,15 +469,15 @@ seqGuidance _                           = ()
 \begin{code}
 -- | Retrieves the template of an unfolding: panics if none is known
 unfoldingTemplate :: Unfolding -> CoreExpr
-unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
-unfoldingTemplate (CompulsoryUnfolding expr)   = expr
+unfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = expr
+unfoldingTemplate (CompulsoryUnfolding expr)     = expr
 unfoldingTemplate _ = panic "getUnfoldingTemplate"
 
 -- | Retrieves the template of an unfolding if possible
 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
-maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
-maybeUnfoldingTemplate (CompulsoryUnfolding expr)   = Just expr
-maybeUnfoldingTemplate _                            = Nothing
+maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = Just expr
+maybeUnfoldingTemplate (CompulsoryUnfolding expr)     = Just expr
+maybeUnfoldingTemplate _                              = Nothing
 
 -- | The constructors that the unfolding could never be: 
 -- returns @[]@ if no information is available
@@ -486,21 +488,25 @@ otherCons _               = []
 -- | Determines if it is certainly the case that the unfolding will
 -- yield a value (something in HNF): returns @False@ if unsure
 isValueUnfolding :: Unfolding -> Bool
-isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
-isValueUnfolding _                                = False
+isValueUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald
+isValueUnfolding _                                  = False
 
 -- | Determines if it possibly the case that the unfolding will
 -- yield a value. Unlike 'isValueUnfolding' it returns @True@
 -- for 'OtherCon'
 isEvaldUnfolding :: Unfolding -> Bool
-isEvaldUnfolding (OtherCon _)                    = True
-isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
-isEvaldUnfolding _                                = False
+isEvaldUnfolding (OtherCon _)                      = True
+isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald
+isEvaldUnfolding _                                  = False
 
 -- | Is the thing we will unfold into certainly cheap?
 isCheapUnfolding :: Unfolding -> Bool
-isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
-isCheapUnfolding _                                = False
+isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _ _) = is_cheap
+isCheapUnfolding _                                  = False
+
+isExpandableUnfolding :: Unfolding -> Bool
+isExpandableUnfolding (CoreUnfolding _ _ _ _ is_expable _) = is_expable
+isExpandableUnfolding _                                    = False
 
 -- | Must this unfolding happen for the code to be executable?
 isCompulsoryUnfolding :: Unfolding -> Bool
@@ -509,9 +515,9 @@ isCompulsoryUnfolding _                       = False
 
 -- | Do we have an available or compulsory unfolding?
 hasUnfolding :: Unfolding -> Bool
-hasUnfolding (CoreUnfolding _ _ _ _ _) = True
-hasUnfolding (CompulsoryUnfolding _)   = True
-hasUnfolding _                         = False
+hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True
+hasUnfolding (CompulsoryUnfolding _)     = True
+hasUnfolding _                           = False
 
 -- | Only returns False if there is no unfolding information available at all
 hasSomeUnfolding :: Unfolding -> Bool
@@ -521,10 +527,10 @@ hasSomeUnfolding _           = True
 -- | Similar to @not . hasUnfolding@, but also returns @True@
 -- if it has an unfolding that says it should never occur
 neverUnfold :: Unfolding -> Bool
-neverUnfold NoUnfolding                                = True
-neverUnfold (OtherCon _)                       = True
-neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
-neverUnfold _                                   = False
+neverUnfold NoUnfolding                                  = True
+neverUnfold (OtherCon _)                         = True
+neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
+neverUnfold _                                     = False
 \end{code}
 
 
index 496d7a0..eaeba10 100644 (file)
@@ -22,7 +22,7 @@ module CoreUnfold (
        mkCompulsoryUnfolding, seqUnfolding,
        evaldUnfolding, mkOtherCon, otherCons,
        unfoldingTemplate, maybeUnfoldingTemplate,
-       isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
+       isEvaldUnfolding, isValueUnfolding, isExpandableUnfolding, isCompulsoryUnfolding,
        hasUnfolding, hasSomeUnfolding, neverUnfold,
 
        couldBeSmallEnoughToInline, 
@@ -71,7 +71,8 @@ mkImplicitUnfolding expr
   = CoreUnfolding (simpleOptExpr emptySubst expr)
                  True
                  (exprIsHNF expr)
-                 (exprIsCheap expr)
+                  (exprIsCheap expr)
+                  (exprIsExpandable expr)
                  (calcUnfoldingGuidance opt_UF_CreationThreshold expr)
 
 mkUnfolding :: Bool -> CoreExpr -> Unfolding
@@ -85,6 +86,8 @@ mkUnfolding top_lvl expr
                  (exprIsCheap expr)
                        -- OK to inline inside a lambda
 
+                  (exprIsExpandable expr)
+
                  (calcUnfoldingGuidance 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
@@ -99,8 +102,8 @@ instance Outputable Unfolding where
   ppr NoUnfolding = ptext (sLit "No unfolding")
   ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
   ppr (CompulsoryUnfolding e) = ptext (sLit "Compulsory") <+> ppr e
-  ppr (CoreUnfolding e top hnf cheap g) 
-       = ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr g, 
+  ppr (CoreUnfolding e top hnf cheap expable g) 
+       = ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr expable <+> ppr g, 
                                     ppr e]
 
 mkCompulsoryUnfolding :: CoreExpr -> Unfolding
@@ -484,13 +487,13 @@ couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold
 
 certainlyWillInline :: Unfolding -> Bool
   -- Sees if the unfolding is pretty certain to inline 
-certainlyWillInline (CoreUnfolding _ _ _ is_cheap (UnfoldIfGoodArgs n_vals _ size _))
+certainlyWillInline (CoreUnfolding _ _ _ is_cheap (UnfoldIfGoodArgs n_vals _ size _))
   = is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold
 certainlyWillInline _
   = False
 
 smallEnoughToInline :: Unfolding -> Bool
-smallEnoughToInline (CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ _ size _))
+smallEnoughToInline (CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ _ size _))
   = size <= opt_UF_UseThreshold
 smallEnoughToInline _
   = False
@@ -561,7 +564,7 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
                -- compulsory unfoldings (see MkId.lhs).
                -- We don't allow them to be inactive
 
-       CoreUnfolding unf_template is_top is_value is_cheap guidance ->
+       CoreUnfolding unf_template is_top is_value is_cheap is_expable guidance ->
 
     let
        result | yes_or_no = Just unf_template
@@ -639,7 +642,8 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
                        text "arg infos" <+> ppr arg_infos,
                        text "interesting continuation" <+> ppr cont_info,
                        text "is value:" <+> ppr is_value,
-                       text "is cheap:" <+> ppr is_cheap,
+                        text "is cheap:" <+> ppr is_cheap,
+                       text "is expandable:" <+> ppr is_expable,
                        text "guidance" <+> ppr guidance,
                        text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
                  result
index 5d33b0f..379da8a 100644 (file)
@@ -25,7 +25,7 @@ module CoreUtils (
 
        -- * Properties of expressions
        exprType, coreAltType, coreAltsType,
-       exprIsDupable, exprIsTrivial, exprIsCheap, 
+       exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
        exprIsHNF,exprOkForSpeculation, exprIsBig, 
        exprIsConApp_maybe, exprIsBottom,
        rhsIsStatic,
@@ -37,7 +37,7 @@ module CoreUtils (
        hashExpr,
 
        -- * Equality
-       cheapEqExpr, tcEqExpr, tcEqExprX,
+       cheapEqExpr, 
 
        -- * Manipulating data constructors and types
        applyTypeToArgs, applyTypeToArg,
@@ -47,11 +47,9 @@ module CoreUtils (
 #include "HsVersions.h"
 
 import CoreSyn
-import CoreFVs
 import PprCore
 import Var
 import SrcLoc
-import VarSet
 import VarEnv
 import Name
 import Module
@@ -462,27 +460,28 @@ Notice that a variable is considered 'cheap': we can push it inside a lambda,
 because sharing will make sure it is only evaluated once.
 
 \begin{code}
-exprIsCheap :: CoreExpr -> Bool
-exprIsCheap (Lit _)           = True
-exprIsCheap (Type _)          = True
-exprIsCheap (Var _)           = True
-exprIsCheap (Note InlineMe _) = True
-exprIsCheap (Note _ e)        = exprIsCheap e
-exprIsCheap (Cast e _)        = exprIsCheap e
-exprIsCheap (Lam x e)         = isRuntimeVar x || exprIsCheap e
-exprIsCheap (Case e _ _ alts) = exprIsCheap e && 
-                               and [exprIsCheap rhs | (_,_,rhs) <- alts]
+exprIsCheap' :: (Id -> Bool) -> CoreExpr -> Bool
+exprIsCheap' _          (Lit _)           = True
+exprIsCheap' _          (Type _)          = True
+exprIsCheap' _          (Var _)           = True
+exprIsCheap' _          (Note InlineMe _) = True
+exprIsCheap' is_conlike (Note _ e)        = exprIsCheap' is_conlike e
+exprIsCheap' is_conlike (Cast e _)        = exprIsCheap' is_conlike e
+exprIsCheap' is_conlike (Lam x e)         = isRuntimeVar x
+                                            || exprIsCheap' is_conlike e
+exprIsCheap' is_conlike (Case e _ _ alts) = exprIsCheap' is_conlike e && 
+                               and [exprIsCheap' is_conlike rhs | (_,_,rhs) <- alts]
        -- Experimentally, treat (case x of ...) as cheap
        -- (and case __coerce x etc.)
        -- This improves arities of overloaded functions where
        -- there is only dictionary selection (no construction) involved
-exprIsCheap (Let (NonRec x _) e)  
-      | isUnLiftedType (idType x) = exprIsCheap e
+exprIsCheap' is_conlike (Let (NonRec x _) e)  
+      | isUnLiftedType (idType x) = exprIsCheap' is_conlike e
       | otherwise                = False
        -- strict lets always have cheap right hand sides,
        -- and do no allocation.
 
-exprIsCheap other_expr         -- Applications and variables
+exprIsCheap' is_conlike other_expr     -- Applications and variables
   = go other_expr []
   where
        -- Accumulate value arguments, then decide
@@ -497,8 +496,8 @@ exprIsCheap other_expr      -- Applications and variables
                ClassOpId _  -> go_sel args
                PrimOpId op  -> go_primop op args
 
-               DataConWorkId _ -> go_pap args
-               _ | length args < idArity f -> go_pap args
+               _ | is_conlike f -> go_pap args
+                  | length args < idArity f -> go_pap args
 
                _ -> isBottomingId f
                        -- Application of a function which
@@ -515,18 +514,24 @@ exprIsCheap other_expr    -- Applications and variables
        -- We'll put up with one constructor application, but not dozens
        
     --------------
-    go_primop op args = primOpIsCheap op && all exprIsCheap args
+    go_primop op args = primOpIsCheap op && all (exprIsCheap' is_conlike) args
        -- In principle we should worry about primops
        -- that return a type variable, since the result
        -- might be applied to something, but I'm not going
        -- to bother to check the number of args
  
     --------------
-    go_sel [arg] = exprIsCheap arg     -- I'm experimenting with making record selection
+    go_sel [arg] = exprIsCheap' is_conlike arg -- I'm experimenting with making record selection
     go_sel _     = False               -- look cheap, so we will substitute it inside a
                                        -- lambda.  Particularly for dictionary field selection.
                -- BUT: Take care with (sel d x)!  The (sel d) might be cheap, but
                --      there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)
+
+exprIsCheap :: CoreExpr -> Bool
+exprIsCheap = exprIsCheap' isDataConWorkId
+
+exprIsExpandable :: CoreExpr -> Bool
+exprIsExpandable = exprIsCheap' isConLikeId
 \end{code}
 
 \begin{code}
@@ -899,7 +904,7 @@ exprIsConApp_maybe expr = analyse (collectArgs expr)
        -- we are effectively duplicating the unfolding
     analyse (Var fun, [])
        | let unf = idUnfolding fun,
-         isCheapUnfolding unf
+         isExpandableUnfolding unf
        = exprIsConApp_maybe (unfoldingTemplate unf)
 
     analyse _ = Nothing
@@ -944,53 +949,6 @@ exprIsBig _            = True
 \end{code}
 
 
-\begin{code}
-tcEqExpr :: CoreExpr -> CoreExpr -> Bool
--- ^ A kind of shallow equality used in rule matching, so does 
--- /not/ look through newtypes or predicate types
-
-tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
-  where
-    rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
-
-tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
-tcEqExprX env (Var v1)    (Var v2)     = rnOccL env v1 == rnOccR env v2
-tcEqExprX _   (Lit lit1)   (Lit lit2)   = lit1 == lit2
-tcEqExprX env (App f1 a1)  (App f2 a2)  = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
-tcEqExprX env (Lam v1 e1)  (Lam v2 e2)  = tcEqExprX (rnBndr2 env v1 v2) e1 e2
-tcEqExprX env (Let (NonRec v1 r1) e1)
-             (Let (NonRec v2 r2) e2)   = tcEqExprX env r1 r2 
-                                      && tcEqExprX (rnBndr2 env v1 v2) e1 e2
-tcEqExprX env (Let (Rec ps1) e1)
-             (Let (Rec ps2) e2)        =  equalLength ps1 ps2
-                                       && and (zipWith eq_rhs ps1 ps2)
-                                       && tcEqExprX env' e1 e2
-                                    where
-                                      env' = foldl2 rn_bndr2 env ps2 ps2
-                                      rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
-                                      eq_rhs       (_,r1) (_,r2) = tcEqExprX env' r1 r2
-tcEqExprX env (Case e1 v1 t1 a1)
-             (Case e2 v2 t2 a2)     =  tcEqExprX env e1 e2
-                                     && tcEqTypeX env t1 t2                      
-                                    && equalLength a1 a2
-                                    && and (zipWith (eq_alt env') a1 a2)
-                                    where
-                                      env' = rnBndr2 env v1 v2
-
-tcEqExprX env (Note n1 e1)  (Note n2 e2)  = eq_note env n1 n2 && tcEqExprX env e1 e2
-tcEqExprX env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && tcEqExprX env e1 e2
-tcEqExprX env (Type t1)     (Type t2)     = tcEqTypeX env t1 t2
-tcEqExprX _   _             _             = False
-
-eq_alt :: RnEnv2 -> CoreAlt -> CoreAlt -> Bool
-eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1  vs2) r1 r2
-
-eq_note :: RnEnv2 -> Note -> Note -> Bool
-eq_note _ (SCC cc1)     (SCC cc2)      = cc1 == cc2
-eq_note _ (CoreNote s1) (CoreNote s2)  = s1 == s2
-eq_note _ _             _              = False
-\end{code}
-
 
 %************************************************************************
 %*                                                                     *
index 1504ab9..e210937 100644 (file)
@@ -310,7 +310,7 @@ pprIdBndrInfo info
     dmd_info  = newDemandInfo info
     lbv_info  = lbvarInfo info
 
-    no_info = isAlwaysActive prag_info && isNoOcc occ_info && 
+    no_info = isDefaultInlinePragma prag_info && isNoOcc occ_info && 
              (case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
              hasNoLBVarInfo lbv_info
 
index 4c144b8..80a7cf6 100644 (file)
@@ -516,12 +516,12 @@ addInlinePrags prags bndr rhs
        (inl:_) -> addInlineInfo inl bndr rhs
 
 addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
-addInlineInfo (Inline phase is_inline) bndr rhs
-  = (attach_phase bndr phase, wrap_inline is_inline rhs)
+addInlineInfo (Inline prag is_inline) bndr rhs
+  = (attach_pragma bndr prag, wrap_inline is_inline rhs)
   where
-    attach_phase bndr phase 
-       | isAlwaysActive phase = bndr   -- Default phase
-       | otherwise            = bndr `setInlinePragma` phase
+    attach_pragma bndr prag
+        | isDefaultInlinePragma prag = bndr
+        | otherwise                  = bndr `setInlinePragma` prag
 
     wrap_inline True  body = mkInlineMe body
     wrap_inline False body = body
index 0c40318..7071ab7 100644 (file)
@@ -387,7 +387,7 @@ dsFExportDynamic id cconv = do
                         , Lam stbl_value ccall_adj
                         ]
 
-        fed = (id `setInlinePragma` NeverActive, io_app)
+        fed = (id `setInlineActivation` NeverActive, io_app)
                -- Never inline the f.e.d. function, because the litlit
                -- might not be in scope in other modules.
 
index 7a27401..1a4a65a 100644 (file)
@@ -578,6 +578,24 @@ instance Binary Activation where
              _ -> do ab <- get bh
                      return (ActiveAfter ab)
 
+instance Binary RuleMatchInfo where
+    put_ bh FunLike = putByte bh 0
+    put_ bh ConLike = putByte bh 1
+    get bh = do
+            h <- getByte bh
+            if h == 1 then return ConLike
+                      else return FunLike
+
+instance Binary InlinePragma where
+    put_ bh (InlinePragma activation match_info) = do
+            put_ bh activation
+            put_ bh match_info
+
+    get bh = do
+           act  <- get bh
+           info <- get bh
+           return (InlinePragma act info)
+
 instance Binary StrictnessMark where
     put_ bh MarkedStrict    = putByte bh 0
     put_ bh MarkedUnboxed   = putByte bh 1
index b679cf6..51e5f8a 100644 (file)
@@ -203,7 +203,7 @@ data IfaceIdInfo
 data IfaceInfoItem
   = HsArity     Arity
   | HsStrictness StrictSig
-  | HsInline     Activation
+  | HsInline     InlinePragma
   | HsUnfold    IfaceExpr
   | HsNoCafRefs
   | HsWorker    Name Arity     -- Worker, if any see IdInfo.WorkerInfo
@@ -660,7 +660,7 @@ instance Outputable IfaceIdInfo where
 instance Outputable IfaceInfoItem where
   ppr (HsUnfold unf)    = ptext (sLit "Unfolding:") <+>
                                        parens (pprIfaceExpr noParens unf)
-  ppr (HsInline act)     = ptext (sLit "Inline:") <+> ppr act
+  ppr (HsInline prag)    = ptext (sLit "Inline:") <+> ppr prag
   ppr (HsArity arity)    = ptext (sLit "Arity:") <+> int arity
   ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
   ppr HsNoCafRefs       = ptext (sLit "HasNoCafRefs")
index 22c1756..8cfc08f 100644 (file)
@@ -1440,8 +1440,8 @@ toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
        -- See Note [IdInfo on nested let-bindings] in IfaceSyn
     id_info = idInfo id
     inline_prag = inlinePragInfo id_info
-    prag_info | isAlwaysActive inline_prag = NoInfo
-             | otherwise                  = HasInfo [HsInline inline_prag]
+    prag_info | isDefaultInlinePragma inline_prag = NoInfo
+             | otherwise                         = HasInfo [HsInline inline_prag]
 
 --------------------------
 toIfaceIdDetails :: IdDetails -> IfaceIdDetails
@@ -1495,11 +1495,13 @@ toIfaceIdInfo id_info
                                        
     ------------  Inline prag  --------------
     inline_prag = inlinePragInfo id_info
-    inline_hsinfo | isAlwaysActive inline_prag     = Nothing
-                 | no_unfolding && not has_worker = Nothing
+    inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
+                 | no_unfolding && not has_worker 
+                      && isFunLike (inlinePragmaRuleMatchInfo inline_prag)
+                                                      = Nothing
                        -- If the iface file give no unfolding info, we 
                        -- don't need to say when inlining is OK!
-                 | otherwise                      = Just (HsInline inline_prag)
+                 | otherwise                         = Just (HsInline inline_prag)
 
 --------------------------
 coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
index 60fd726..5c78927 100644 (file)
@@ -561,7 +561,7 @@ addExternal (id,rhs) needed
                     spec_ids
 
     idinfo        = idInfo id
-    dont_inline           = isNeverActive (inlinePragInfo idinfo)
+    dont_inline           = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
     loop_breaker   = isNonRuleLoopBreaker (occInfo idinfo)
     bottoming_fn   = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
     spec_ids      = specInfoFreeVars (specInfo idinfo)
index 07ee66f..5c595f5 100644 (file)
@@ -244,6 +244,12 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
                     { token (ITinline_prag True) }
   "{-#" $whitechar* (NO(T?)INLINE|no(t?)inline) / { notFollowedByPragmaChar }
                                        { token (ITinline_prag False) }
+  "{-#" $whitechar* (INLINE|inline)
+        $whitechar+ (CONLIKE|conlike) / { notFollowedByPragmaChar }
+                                        { token (ITinline_conlike_prag True) }
+  "{-#" $whitechar* (NO(T)?INLINE|no(t?)inline)
+        $whitechar+ (CONLIKE|constructorlike) / { notFollowedByPragmaChar }
+                                        { token (ITinline_conlike_prag False) }
   "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e) / { notFollowedByPragmaChar }
                                        { token ITspec_prag }
   "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
@@ -490,6 +496,7 @@ data Token
 
        -- Pragmas
   | ITinline_prag Bool         -- True <=> INLINE, False <=> NOINLINE
+  | ITinline_conlike_prag Bool  -- same
   | ITspec_prag                        -- SPECIALISE   
   | ITspec_inline_prag Bool    -- SPECIALISE INLINE (or NOINLINE)
   | ITsource_prag
index d9df620..5fbbcad 100644 (file)
@@ -47,7 +47,7 @@ import Module
 import StaticFlags     ( opt_SccProfilingOn, opt_Hpc )
 import Type            ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
 import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
-                         Activation(..), defaultInlineSpec )
+                         Activation(..), RuleMatchInfo(..), defaultInlineSpec )
 import DynFlags
 import OrdList
 import HaddockParse
@@ -254,6 +254,7 @@ incorrect.
  'using'    { L _ ITusing }     -- for list transform extension
 
  '{-# INLINE'            { L _ (ITinline_prag _) }
+ '{-# INLINE_CONLIKE'     { L _ (ITinline_conlike_prag _) }
  '{-# SPECIALISE'        { L _ ITspec_prag }
  '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _) }
  '{-# SOURCE'     { L _ ITsource_prag }
@@ -1287,12 +1288,14 @@ 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 '#-}'        
-                               { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 (getINLINE $1)))) }
+                               { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 FunLike (getINLINE $1)))) }
+        | '{-# INLINE_CONLIKE' activation qvar '#-}'
+                                { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 ConLike (getINLINE_CONLIKE $1)))) }
        | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
                                { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec) 
                                            | t <- $4] }
        | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
-                               { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 (getSPEC_INLINE $1)))
+                               { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 FunLike (getSPEC_INLINE $1)))
                                            | t <- $5] }
        | '{-# SPECIALISE' 'instance' inst_type '#-}'
                                { LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
@@ -2013,6 +2016,7 @@ 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
 
 getDOCNEXT (L _ (ITdocCommentNext x)) = x
index bccf27f..382b333 100644 (file)
@@ -58,7 +58,9 @@ import TypeRep          ( Kind )
 import RdrName         ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
                          isRdrDataCon, isUnqual, getRdrName, isQual,
                          setRdrNameSpace, showRdrName )
-import BasicTypes      ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
+import BasicTypes      ( maxPrecedence, Activation, RuleMatchInfo,
+                          InlinePragma(..),  InlineSpec(..),
+                          alwaysInlineSpec, neverInlineSpec )
 import Lexer           ( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
 import TysWiredIn      ( unitTyCon ) 
 import ForeignCall     ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
@@ -923,11 +925,13 @@ 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) }
 
-mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
+mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec
 -- The Maybe is becuase the user can omit the activation spec (and usually does)
-mkInlineSpec Nothing   True  = alwaysInlineSpec        -- INLINE
-mkInlineSpec Nothing   False = neverInlineSpec         -- NOINLINE
-mkInlineSpec (Just act) inl   = Inline act inl
+mkInlineSpec Nothing    match_info True  = alwaysInlineSpec match_info
+                                                                -- INLINE
+mkInlineSpec Nothing   match_info False = neverInlineSpec  match_info
+                                                                -- NOINLINE
+mkInlineSpec (Just act) match_info inl   = Inline (InlinePragma act match_info) inl
 
 
 -----------------------------------------------------------------------------
index d4aef90..54490f4 100644 (file)
@@ -10,7 +10,7 @@ module CSE (
 
 #include "HsVersions.h"
 
-import Id              ( Id, idType, idInlinePragma, zapIdOccInfo )
+import Id              ( Id, idType, idInlineActivation, zapIdOccInfo )
 import CoreUtils       ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
 import DataCon         ( isUnboxedTupleCon )
 import Type            ( tyConAppArgs )
@@ -201,8 +201,8 @@ do_one env (id, rhs)
        Nothing             -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
   where
     (env', id') = addBinder env id
-    rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs
-        | otherwise                          = rhs
+    rhs' | isAlwaysActive (idInlineActivation id) = cseExpr env' rhs
+        | otherwise                              = rhs
                -- See Note [CSE for INLINE and NOINLINE]
 
 tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
index 83fbad1..c5f323e 100644 (file)
@@ -864,7 +864,7 @@ occAnalApp env (Var fun, args)
   where
     fun_uniq = idUnique fun
     fun_uds  = mkOneOcc env fun (valArgCount args > 0)
-    is_pap = isDataConWorkId fun || valArgCount args < idArity fun
+    is_pap = isConLikeId fun || valArgCount args < idArity fun
 
                 -- Hack for build, fold, runST
     args_stuff  | fun_uniq == buildIdKey    = appSpecial env 2 [True,True]  args
index a2e06a0..0a7575a 100644 (file)
@@ -356,7 +356,7 @@ doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) 
   =  not (isNilOL fs) && want_to_float && can_float
   where
-     want_to_float = isTopLevel lvl || exprIsCheap rhs
+     want_to_float = isTopLevel lvl || exprIsExpandable rhs
      can_float = case ff of
                   FltLifted  -> True
                   FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
@@ -677,7 +677,7 @@ substUnfolding :: SimplEnv -> Unfolding -> Unfolding
 substUnfolding _   NoUnfolding                = NoUnfolding
 substUnfolding _   (OtherCon cons)            = OtherCon cons
 substUnfolding env (CompulsoryUnfolding rhs)   = CompulsoryUnfolding (substExpr env rhs)
-substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
+substUnfolding env (CoreUnfolding rhs t u v w g) = CoreUnfolding (substExpr env rhs) t u v w g
 
 ------------------
 substWorker :: SimplEnv -> WorkerInfo -> WorkerInfo
index 1c6768d..c212893 100644 (file)
@@ -370,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
 
@@ -622,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
@@ -778,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
@@ -801,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
index 10965a1..4f75769 100644 (file)
@@ -461,7 +461,7 @@ prepareRhs env0 rhs0
         where
           is_val = n_val_args > 0       -- There is at least one arg
                                         -- ...and the fun a constructor or PAP
-                 && (isDataConWorkId fun || n_val_args < idArity fun)
+                 && (isConLikeId fun || n_val_args < idArity fun)
     go _ env other
         = return (False, env, other)
 \end{code}
@@ -578,7 +578,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
   = return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr)
   where
     unfolding | omit_unfolding = NoUnfolding
-             | otherwise      = mkUnfolding  (isTopLevel top_lvl) new_rhs
+             | otherwise      = mkUnfolding (isTopLevel top_lvl) new_rhs
     old_info    = idInfo old_bndr
     occ_info    = occInfo old_info
     wkr                = substWorker env (workerInfo old_info)
index d788b1b..0cf7a44 100644 (file)
@@ -32,9 +32,9 @@ module Rules (
 import CoreSyn         -- All of it
 import OccurAnal       ( occurAnalyseExpr )
 import CoreFVs         ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars )
-import CoreUtils       ( tcEqExprX, exprType )
+import CoreUtils       ( exprType )
 import PprCore         ( pprRules )
-import Type            ( Type, TvSubstEnv )
+import Type            ( Type, TvSubstEnv, tcEqTypeX )
 import TcType          ( tcSplitTyConApp_maybe )
 import CoreTidy                ( tidyRules )
 import Id
@@ -490,79 +490,23 @@ match menv subst (Var v1) e2
 
 match menv subst e1 (Note _ e2)
   = match menv subst e1 e2
-       -- Note [Notes in RULE matching]
-       -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-       -- Look through Notes.  In particular, we don't want to
-       -- be confused by InlineMe notes.  Maybe we should be more
-       -- careful about profiling notes, but for now I'm just
-       -- riding roughshod over them.  
-       --- See Note [Notes in call patterns] in SpecConstr
-
--- Here is another important rule: if the term being matched is a
--- variable, we expand it so long as its unfolding is a WHNF
--- (Its occurrence information is not necessarily up to date,
---  so we don't use it.)
-match menv subst e1 (Var v2)
-  | isCheapUnfolding unfolding
-  = match menv subst e1 (unfoldingTemplate unfolding)
+       -- See Note [Notes in RULE matching]
+
+match menv subst e1 (Var v2)      -- Note [Expanding variables]
+  | not (locallyBoundR rn_env v2) -- Note [Do not expand locally-bound variables]
+  , Just e2' <- expandId v2'
+  = match (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2'
   where
-    rn_env    = me_env menv
-    unfolding = idUnfolding (lookupRnInScope rn_env (rnOccR rn_env v2))
+    v2'    = lookupRnInScope rn_env v2
+    rn_env = me_env menv
        -- Notice that we look up v2 in the in-scope set
        -- See Note [Lookup in-scope]
-       -- Remember to apply any renaming first (hence rnOccR)
-
--- Note [Matching lets]
--- ~~~~~~~~~~~~~~~~~~~~
--- Matching a let-expression.  Consider
---     RULE forall x.  f (g x) = <rhs>
--- and target expression
---     f (let { w=R } in g E))
--- Then we'd like the rule to match, to generate
---     let { w=R } in (\x. <rhs>) E
--- In effect, we want to float the let-binding outward, to enable
--- the match to happen.  This is the WHOLE REASON for accumulating
--- bindings in the SubstEnv
---
--- We can only do this if
---     (a) Widening the scope of w does not capture any variables
---         We use a conservative test: w is not already in scope
---         If not, we clone the binders, and substitute
---     (b) The free variables of R are not bound by the part of the
---         target expression outside the let binding; e.g.
---             f (\v. let w = v+1 in g E)
---         Here we obviously cannot float the let-binding for w.
---
--- You may think rule (a) would never apply, because rule matching is
--- mostly invoked from the simplifier, when we have just run substExpr 
--- over the argument, so there will be no shadowing anyway.
--- The fly in the ointment is that the forall'd variables of the
--- RULE itself are considered in scope.
---
--- I though of various cheapo ways to solve this tiresome problem,
--- but ended up doing the straightforward thing, which is to 
--- clone the binders if they are in scope.  It's tiresome, and
--- potentially inefficient, because of the calls to substExpr,
--- but I don't think it'll happen much in pracice.
-
-{-  Cases to think about
-       (let x=y+1 in \x. (x,x))
-               --> let x=y+1 in (\x1. (x1,x1))
-       (\x. let x = y+1 in (x,x))
-               --> let x1 = y+1 in (\x. (x1,x1)
-       (let x=y+1 in (x,x), let x=y-1 in (x,x))
-               --> let x=y+1 in let x1=y-1 in ((x,x),(x1,x1))
-
-Watch out!
-       (let x=y+1 in let z=x+1 in (z,z)
-               --> matches (p,p) but watch out that the use of 
-                       x on z's rhs is OK!
-I'm removing the cloning because that makes the above case
-fail, because the inner let looks as if it has locally-bound vars -}
+       -- No need to apply any renaming first (hence no rnOccR)
+       -- becuase of the not-locallyBoundR
 
 match menv (tv_subst, id_subst, binds) e1 (Let bind e2)
-  | all freshly_bound bndrs,
-    not (any locally_bound bind_fvs)
+  | all freshly_bound bndrs    -- See Note [Matching lets]
+  , not (any (locallyBoundR rn_env) bind_fvs)
   = match (menv { me_env = rn_env' }) 
          (tv_subst, id_subst, binds `snocOL` bind')
          e1 e2'
@@ -570,21 +514,10 @@ match menv (tv_subst, id_subst, binds) e1 (Let bind e2)
     rn_env   = me_env menv
     bndrs    = bindersOf  bind
     bind_fvs = varSetElems (bindFreeVars bind)
-    locally_bound x   = inRnEnvR rn_env x
     freshly_bound x = not (x `rnInScope` rn_env)
-    bind' = bind
-    e2'   = e2
+    bind'   = bind
+    e2'     = e2
     rn_env' = extendRnInScopeList rn_env bndrs
-{-
-    (rn_env', bndrs') = mapAccumL rnBndrR rn_env bndrs
-    s_prs = [(bndr, Var bndr') | (bndr,bndr') <- zip bndrs bndrs', bndr /= bndr']
-    subst = mkSubst (rnInScopeSet rn_env) emptyVarEnv (mkVarEnv s_prs)
-    (bind', e2') | null s_prs = (bind,   e2)
-                | otherwise  = (s_bind, substExpr subst e2)
-    s_bind = case bind of
-               NonRec {} -> NonRec (head bndrs') (head rhss)
-               Rec {}    -> Rec (bndrs' `zip` map (substExpr subst) rhss)
--}
 
 match _ subst (Lit lit1) (Lit lit2)
   | lit1 == lit2
@@ -632,32 +565,6 @@ match menv subst (Cast e1 co1) (Cast e2 co2)
   = do { subst1 <- match_ty menv subst co1 co2
        ; match menv subst1 e1 e2 }
 
-{-     REMOVING OLD CODE: I think that the above handling for let is 
-                          better than the stuff here, which looks 
-                          pretty suspicious to me.  SLPJ Sept 06
--- This is an interesting rule: we simply ignore lets in the 
--- term being matched against!  The unfolding inside it is (by assumption)
--- already inside any occurrences of the bound variables, so we'll expand
--- them when we encounter them.  This gives a chance of matching
---     forall x,y.  f (g (x,y))
--- against
---     f (let v = (a,b) in g v)
-
-match menv subst e1 (Let bind e2)
-  = match (menv { me_env = rn_env' }) subst e1 e2
-  where
-    (rn_env', _bndrs') = mapAccumL rnBndrR (me_env menv) (bindersOf bind)
-       -- It's important to do this renaming, so that the bndrs
-       -- are brought into the local scope. For example:
-       -- Matching
-       --      forall f,x,xs. f (x:xs)
-       --   against
-       --      f (let y = e in (y:[]))
-       -- We must not get success with x->y!  So we record that y is
-       -- locally bound (with rnBndrR), and proceed.  The Var case
-       -- will fail when trying to bind x->y
--}
-
 -- Everything else fails
 match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr e1) $$ (text "e2:" <+> ppr e2)) $ 
                         Nothing
@@ -691,7 +598,7 @@ match_var menv subst@(tv_subst, id_subst, binds) v1 e2
                                                -- c.f. match_ty below
                        ; return (tv_subst', extendVarEnv id_subst v1' e2, binds) }
 
-       Just e1' | tcEqExprX (nukeRnEnvL rn_env) e1' e2 
+       Just e1' | eqExpr (nukeRnEnvL rn_env) e1' e2 
                 -> Just subst
 
                 | otherwise
@@ -749,6 +656,85 @@ match_ty menv (tv_subst, id_subst, binds) ty1 ty2
        ; return (tv_subst', id_subst, binds) }
 \end{code}
 
+Note [Expanding variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is another Very Important rule: if the term being matched is a
+variable, we expand it so long as its unfolding is "expandable". (Its
+occurrence information is not necessarily up to date, so we don't use
+it.)  By "expandable" we mean a WHNF or a "constructor-like" application.
+This is the key reason for "constructor-like" Ids.  If we have
+     {-# NOINLINE [1] CONLIKE g #-}
+     {-# RULE f (g x) = h x #-}
+then in the term
+   let v = g 3 in ....(f v)....
+we want to make the rule fire, to replace (f v) with (h 3). 
+
+Note [Do not expand locally-bound variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Do *not* expand locally-bound variables, else there's a worry that the
+unfolding might mention variables that are themselves renamed.
+Example
+         case x of y { (p,q) -> ...y... }
+Don't expand 'y' to (p,q) because p,q might themselves have been 
+renamed.  Essentially we only expand unfoldings that are "outside" 
+the entire match.
+
+Hence, (a) the guard (not (isLocallyBoundR v2))
+       (b) when we expand we nuke the renaming envt (nukeRnEnvR).
+
+Note [Notes in RULE matching]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Look through Notes.  In particular, we don't want to
+be confused by InlineMe notes.  Maybe we should be more
+careful about profiling notes, but for now I'm just
+riding roughshod over them.  
+See Note [Notes in call patterns] in SpecConstr
+
+Note [Matching lets]
+~~~~~~~~~~~~~~~~~~~~
+Matching a let-expression.  Consider
+       RULE forall x.  f (g x) = <rhs>
+and target expression
+       f (let { w=R } in g E))
+Then we'd like the rule to match, to generate
+       let { w=R } in (\x. <rhs>) E
+In effect, we want to float the let-binding outward, to enable
+the match to happen.  This is the WHOLE REASON for accumulating
+bindings in the SubstEnv
+
+We can only do this if
+       (a) Widening the scope of w does not capture any variables
+           We use a conservative test: w is not already in scope
+           If not, we clone the binders, and substitute
+       (b) The free variables of R are not bound by the part of the
+           target expression outside the let binding; e.g.
+               f (\v. let w = v+1 in g E)
+           Here we obviously cannot float the let-binding for w.
+
+You may think rule (a) would never apply, because rule matching is
+mostly invoked from the simplifier, when we have just run substExpr 
+over the argument, so there will be no shadowing anyway.
+The fly in the ointment is that the forall'd variables of the
+RULE itself are considered in scope.
+
+I though of various ways to solve (a).  One plan was to 
+clone the binders if they are in scope.  But watch out!
+       (let x=y+1 in let z=x+1 in (z,z)
+               --> should match (p,p) but watch out that 
+                   the use of x on z's rhs is OK!
+If we clone x, then the let-binding for 'z' is then caught by (b), 
+at least unless we elaborate the RnEnv stuff a bit.
+
+So for we simply fail to match unless both (a) and (b) hold.
+
+Other cases to think about
+       (let x=y+1 in \x. (x,x))
+               --> let x=y+1 in (\x1. (x1,x1))
+       (\x. let x = y+1 in (x,x))
+               --> let x1 = y+1 in (\x. (x1,x1)
+       (let x=y+1 in (x,x), let x=y-1 in (x,x))
+               --> let x=y+1 in let x1=y-1 in ((x,x),(x1,x1))
+
 
 Note [Lookup in-scope]
 ~~~~~~~~~~~~~~~~~~~~~~
@@ -785,19 +771,89 @@ at all.
 That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
 is so important.
 
+\begin{code}
+eqExpr :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
+-- ^ A kind of shallow equality used in rule matching, so does 
+-- /not/ look through newtypes or predicate types
+
+eqExpr env (Var v1) (Var v2)
+  | rnOccL env v1 == rnOccR env v2
+  = True
+
+-- The next two rules expand non-local variables
+-- C.f. Note [Expanding variables]
+-- and  Note [Do not expand locally-bound variables]
+eqExpr env (Var v1) e2
+  | not (locallyBoundL env v1)
+  , Just e1' <- expandId (lookupRnInScope env v1)
+  = eqExpr (nukeRnEnvL env) e1' e2
+
+eqExpr env e1 (Var v2)
+  | not (locallyBoundR env v2)
+  , Just e2' <- expandId (lookupRnInScope env v2)
+  = eqExpr (nukeRnEnvR env) e1 e2'
+
+eqExpr _   (Lit lit1)    (Lit lit2)    = lit1 == lit2
+eqExpr env (App f1 a1)   (App f2 a2)   = eqExpr env f1 f2 && eqExpr env a1 a2
+eqExpr env (Lam v1 e1)   (Lam v2 e2)   = eqExpr (rnBndr2 env v1 v2) e1 e2
+eqExpr env (Note n1 e1)  (Note n2 e2)  = eq_note env n1 n2 && eqExpr env e1 e2
+eqExpr env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && eqExpr env e1 e2
+eqExpr env (Type t1)     (Type t2)     = tcEqTypeX env t1 t2
+
+eqExpr env (Let (NonRec v1 r1) e1)
+          (Let (NonRec v2 r2) e2) =  eqExpr env r1 r2 
+                                  && eqExpr (rnBndr2 env v1 v2) e1 e2
+eqExpr env (Let (Rec ps1) e1)
+          (Let (Rec ps2) e2)      =  equalLength ps1 ps2
+                                  && and (zipWith eq_rhs ps1 ps2)
+                                  && eqExpr env' e1 e2
+                                  where
+                                     env' = foldl2 rn_bndr2 env ps2 ps2
+                                     rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
+                                     eq_rhs       (_,r1) (_,r2) = eqExpr env' r1 r2
+eqExpr env (Case e1 v1 t1 a1)
+          (Case e2 v2 t2 a2) =  eqExpr env e1 e2
+                              && tcEqTypeX env t1 t2                      
+                             && equalLength a1 a2
+                             && and (zipWith (eq_alt env') a1 a2)
+                             where
+                               env' = rnBndr2 env v1 v2
+
+eqExpr _   _             _             = False
+
+eq_alt :: RnEnv2 -> CoreAlt -> CoreAlt -> Bool
+eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && eqExpr (rnBndrs2 env vs1  vs2) r1 r2
+
+eq_note :: RnEnv2 -> Note -> Note -> Bool
+eq_note _ (SCC cc1)     (SCC cc2)      = cc1 == cc2
+eq_note _ (CoreNote s1) (CoreNote s2)  = s1 == s2
+eq_note _ _             _              = False
+\end{code}
+
+Auxiliary functions
+
+\begin{code}
+locallyBoundL, locallyBoundR :: RnEnv2 -> Var -> Bool
+locallyBoundL rn_env v = inRnEnvL rn_env v
+locallyBoundR rn_env v = inRnEnvR rn_env v
+
+
+expandId :: Id -> Maybe CoreExpr
+expandId id
+  | isExpandableUnfolding unfolding = Just (unfoldingTemplate unfolding)
+  | otherwise                      = Nothing
+  where
+    unfolding = idUnfolding id
+\end{code}
 
 %************************************************************************
 %*                                                                     *
-\subsection{Checking a program for failing rule applications}
+                   Rule-check the program                                                                              
 %*                                                                     *
 %************************************************************************
 
------------------------------------------------------
-                       Game plan
------------------------------------------------------
-
-We want to know what sites have rules that could have fired but didn't.
-This pass runs over the tree (without changing it) and reports such.
+   We want to know what sites have rules that could have fired but didn't.
+   This pass runs over the tree (without changing it) and reports such.
 
 \begin{code}
 -- | Report partial matches for rules beginning with the specified
index 4d8efdd..015332f 100644 (file)
@@ -15,8 +15,8 @@ module Specialise ( specProgram ) where
 #include "HsVersions.h"
 
 import Id              ( Id, idName, idType, mkUserLocal, idCoreRules,
-                         idInlinePragma, setInlinePragma, setIdUnfolding,
-                         isLocalId ) 
+                         idInlineActivation, setInlineActivation, setIdUnfolding,
+                          isLocalId ) 
 import TcType          ( Type, mkTyVarTy, tcSplitSigmaTy, 
                          tyVarsOfTypes, tyVarsOfTheta, isClassPred,
                          tcCmpType, isUnLiftedType
@@ -829,7 +829,7 @@ specDefn subst calls fn rhs
     (tyvars, theta, _) = tcSplitSigmaTy fn_type
     n_tyvars          = length tyvars
     n_dicts           = length theta
-    inline_prag        = idInlinePragma fn
+    inline_act         = idInlineActivation fn
 
        -- It's important that we "see past" any INLINE pragma
        -- else we'll fail to specialise an INLINE thing
@@ -913,7 +913,7 @@ specDefn subst calls fn rhs
                rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args))
                spec_env_rule = mkLocalRule
                                  rule_name
-                                 inline_prag   -- Note [Auto-specialisation and RULES]
+                                 inline_act    -- Note [Auto-specialisation and RULES]
                                  (idName fn)
                                  (poly_tyvars ++ inst_dict_ids)
                                  inst_args 
@@ -922,7 +922,7 @@ specDefn subst calls fn rhs
                -- Add the { d1' = dx1; d2' = dx2 } usage stuff
                final_uds = foldr addDictBind rhs_uds dx_binds
 
-               spec_pr | inline_rhs = (spec_f `setInlinePragma` inline_prag, Note InlineMe spec_rhs)
+               spec_pr | inline_rhs = (spec_f `setInlineActivation` inline_act, Note InlineMe spec_rhs)
                        | otherwise  = (spec_f,                               spec_rhs)
 
           ; return (Just (spec_pr, final_uds, spec_env_rule)) } }
@@ -1068,7 +1068,8 @@ Note [Inline specialisations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We transfer to the specialised function any INLINE stuff from the
 original.  This means (a) the Activation in the IdInfo, and (b) any
-InlineMe on the RHS.  
+InlineMe on the RHS.  We do not, however, transfer the RuleMatchInfo
+since we do not expect the specialisation to occur in rewrite rules.
 
 This is a change (Jun06).  Previously the idea is that the point of
 inlining was precisely to specialise the function at its call site,
index 41f574a..6dc0fb7 100644 (file)
@@ -29,7 +29,7 @@ import CoreUtils      ( exprIsHNF, exprIsTrivial )
 import CoreArity       ( exprArity )
 import DataCon         ( dataConTyCon )
 import TyCon           ( isProductTyCon, isRecursiveTyCon )
-import Id              ( Id, idType, idInlinePragma,
+import Id              ( Id, idType, idInlineActivation,
                          isDataConWorkId, isGlobalId, idArity,
 #ifdef OLD_STRICTNESS
                          idDemandInfo,  idStrictness, idCprInfo, idName,
@@ -463,7 +463,7 @@ mkSigTy :: TopLevelFlag -> RecFlag -> Id -> CoreExpr -> DmdType -> (DmdEnv, Stri
 mkSigTy top_lvl rec_flag id rhs dmd_ty 
   = mk_sig_ty never_inline thunk_cpr_ok rhs dmd_ty
   where
-    never_inline = isNeverActive (idInlinePragma id)
+    never_inline = isNeverActive (idInlineActivation id)
     maybe_id_dmd = idNewDemandInfo_maybe id
        -- Is Nothing the first time round
 
index 71f9ef8..30754e5 100644 (file)
@@ -15,7 +15,7 @@ import CoreArity      ( exprArity )
 import Var
 import Id              ( Id, idType, isOneShotLambda, 
                          setIdNewStrictness, mkWorkerId,
-                         setIdWorkerInfo, setInlinePragma,
+                         setIdWorkerInfo, setInlineActivation,
                          setIdArity, idInfo )
 import MkId            ( lazyIdKey, lazyIdUnfolding )
 import Type            ( Type )
@@ -25,7 +25,8 @@ import NewDemand        ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
                        )
 import UniqSupply
 import Unique          ( hasKey )
-import BasicTypes      ( RecFlag(..), isNonRec, isNeverActive )
+import BasicTypes      ( RecFlag(..), isNonRec, isNeverActive,
+                          Activation, inlinePragmaActivation )
 import VarEnv          ( isEmptyVarEnv )
 import Maybes          ( orElse )
 import WwLib
@@ -196,7 +197,7 @@ tryWW is_rec fn_id rhs
   |  -- isNonRec is_rec &&     -- Now omitted: see Note [Don't w/w inline things]
      certainlyWillInline unfolding
 
-  || isNeverActive inline_prag
+  || isNeverActive inline_act
        -- No point in worker/wrappering if the thing is never inlined!
        -- Because the no-inline prag will prevent the wrapper ever
        -- being inlined at a call site. 
@@ -207,7 +208,7 @@ tryWW is_rec fn_id rhs
     splitThunk new_fn_id rhs
 
   | is_fun && worthSplittingFun wrap_dmds res_info
-  = splitFun new_fn_id fn_info wrap_dmds res_info inline_prag rhs
+  = splitFun new_fn_id fn_info wrap_dmds res_info inline_act rhs
 
   | otherwise
   = return [ (new_fn_id, rhs) ]
@@ -216,7 +217,7 @@ tryWW is_rec fn_id rhs
     fn_info     = idInfo fn_id
     maybe_fn_dmd = newDemandInfo fn_info
     unfolding   = unfoldingInfo fn_info
-    inline_prag  = inlinePragInfo fn_info
+    inline_act   = inlinePragmaActivation (inlinePragInfo fn_info)
 
        -- In practice it always will have a strictness 
        -- signature, even if it's a uninformative one
@@ -236,9 +237,9 @@ tryWW is_rec fn_id rhs
     is_thunk  = not is_fun && not (exprIsHNF rhs)
 
 ---------------------
-splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> InlinePragInfo -> Expr Var
+splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Activation -> Expr Var
          -> UniqSM [(Id, CoreExpr)]
-splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
+splitFun fn_id fn_info wrap_dmds res_info inline_act rhs
   = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) 
     (do {
        -- The arity should match the signature
@@ -247,13 +248,14 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
     ; let
        work_rhs = work_fn rhs
        work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs) 
-                       `setInlinePragma` inline_prag
-                               -- Any inline pragma (which sets when inlining is active) 
+                       `setInlineActivation` inline_act
+                               -- Any inline activation (which sets when inlining is active) 
                                -- on the original function is duplicated on the worker and wrapper
                                -- It *matters* that the pragma stays on the wrapper
                                -- It seems sensible to have it on the worker too, although we
                                -- can't think of a compelling reason. (In ptic, INLINE things are 
-                               -- not w/wd)
+                               -- not w/wd). However, the RuleMatchInfo is not transferred since
+                                -- it does not make sense for workers to be constructorlike.
                        `setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info)
                                -- Even though we may not be at top level, 
                                -- it's ok to give it an empty DmdEnv
index 896ae44..74879f3 100644 (file)
@@ -755,7 +755,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags)
        -- Create the result bindings
        ; let dict_constr   = classDataCon clas
              inline_prag | null dfun_dicts  = []
-                         | otherwise        = [L loc (InlinePrag (Inline AlwaysActive True))]
+                         | otherwise        = [L loc (InlinePrag (alwaysInlineSpec FunLike))]
                      -- Always inline the dfun; this is an experimental decision
                      -- because it makes a big performance difference sometimes.
                      -- Often it means we can do the method selection, and then