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,
 
        CompilerPhase, 
        Activation(..), isActive, isNeverActive, isAlwaysActive,
+        RuleMatchInfo(..), isConLike, isFunLike,
+        InlinePragma(..), defaultInlinePragma, isDefaultInlinePragma,
+        inlinePragmaActivation, inlinePragmaRuleMatchInfo,
+        setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
        InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec,
 
        SuccessFlag(..), succeeded, failed, successIf
        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
 
                | 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
 data InlineSpec
-  = Inline 
-       Activation      -- Says during which phases inlining is allowed
+  = Inline
+        InlinePragma
        Bool            -- True  <=> INLINE
                        -- False <=> NOINLINE
   deriving( Eq )
 
        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 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
     
 instance Outputable InlineSpec where
-   ppr (Inline act is_inline)  
+   ppr (Inline (InlinePragma act match_info) is_inline)  
        | is_inline = ptext (sLit "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")
        | 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
 
 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,
        isPrimOpId, isPrimOpId_maybe, 
        isFCallId, isFCallId_maybe,
        isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
-       isBottomingId, idIsFrom,
+        isConLikeId, isBottomingId, idIsFrom,
         isTickBoxOp, isTickBoxOp_maybe,
        hasNoBinding, 
 
        -- ** Inline pragma stuff
         isTickBoxOp, isTickBoxOp_maybe,
        hasNoBinding, 
 
        -- ** Inline pragma stuff
-       idInlinePragma, setInlinePragma, modifyInlinePragma, 
+       idInlinePragma, setInlinePragma, modifyInlinePragma,
+        idInlineActivation, setInlineActivation, idRuleMatchInfo,
 
        -- ** One-shot lambdas
        isOneShotBndr, isOneShotLambda, isStateHackType,
 
        -- ** 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}
 OK not to if optimisation is switched off.
 
 \begin{code}
-idInlinePragma :: Id -> InlinePragInfo
+idInlinePragma :: Id -> InlinePragma
 idInlinePragma id = inlinePragInfo (idInfo id)
 
 idInlinePragma id = inlinePragInfo (idInfo id)
 
-setInlinePragma :: Id -> InlinePragInfo -> Id
+setInlinePragma :: Id -> InlinePragma -> Id
 setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) 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
 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}
 
 
 \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
        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: 
        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 }
 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 }
 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,
            workerInfo          = NoWorker,
            unfoldingInfo       = noUnfolding,
            lbvarInfo           = NoLBVarInfo,
-           inlinePragInfo      = AlwaysActive,
+           inlinePragInfo      = defaultInlinePragma,
            occInfo             = NoOccInfo,
            newDemandInfo       = Nothing,
            newStrictnessInfo   = Nothing
            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
 --
 -- 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}
 
 
 \end{code}
 
 
index 1b3a9d7..4d8f3cb 100644 (file)
@@ -42,7 +42,8 @@ module CoreSyn (
        
        -- ** Predicates and deconstruction on 'Unfolding'
        unfoldingTemplate, maybeUnfoldingTemplate, otherCons, 
        
        -- ** Predicates and deconstruction on 'Unfolding'
        unfoldingTemplate, maybeUnfoldingTemplate, otherCons, 
-       isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
+       isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
+        isExpandableUnfolding, isCompulsoryUnfolding,
        hasUnfolding, hasSomeUnfolding, neverUnfold,
 
        -- * Strictness
        hasUnfolding, hasSomeUnfolding, neverUnfold,
 
        -- * Strictness
@@ -412,6 +413,7 @@ data Unfolding
                Bool
                Bool
                Bool
                Bool
                Bool
                Bool
+                Bool
                UnfoldingGuidance
   -- ^ An unfolding with redundant cached information. Parameters:
   --
                UnfoldingGuidance
   -- ^ An unfolding with redundant cached information. Parameters:
   --
@@ -455,8 +457,8 @@ mkOtherCon :: [AltCon] -> Unfolding
 mkOtherCon = OtherCon
 
 seqUnfolding :: 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 -> ()
 seqUnfolding _ = ()
 
 seqGuidance :: UnfoldingGuidance -> ()
@@ -467,15 +469,15 @@ seqGuidance _                           = ()
 \begin{code}
 -- | Retrieves the template of an unfolding: panics if none is known
 unfoldingTemplate :: Unfolding -> CoreExpr
 \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
 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
 
 -- | 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
 -- | 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
 
 -- | 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
 
 -- | 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
 
 -- | 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
 
 -- | 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
 
 -- | 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
 -- | 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}
 
 
 \end{code}
 
 
index 496d7a0..eaeba10 100644 (file)
@@ -22,7 +22,7 @@ module CoreUnfold (
        mkCompulsoryUnfolding, seqUnfolding,
        evaldUnfolding, mkOtherCon, otherCons,
        unfoldingTemplate, maybeUnfoldingTemplate,
        mkCompulsoryUnfolding, seqUnfolding,
        evaldUnfolding, mkOtherCon, otherCons,
        unfoldingTemplate, maybeUnfoldingTemplate,
-       isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
+       isEvaldUnfolding, isValueUnfolding, isExpandableUnfolding, isCompulsoryUnfolding,
        hasUnfolding, hasSomeUnfolding, neverUnfold,
 
        couldBeSmallEnoughToInline, 
        hasUnfolding, hasSomeUnfolding, neverUnfold,
 
        couldBeSmallEnoughToInline, 
@@ -71,7 +71,8 @@ mkImplicitUnfolding expr
   = CoreUnfolding (simpleOptExpr emptySubst expr)
                  True
                  (exprIsHNF expr)
   = CoreUnfolding (simpleOptExpr emptySubst expr)
                  True
                  (exprIsHNF expr)
-                 (exprIsCheap expr)
+                  (exprIsCheap expr)
+                  (exprIsExpandable expr)
                  (calcUnfoldingGuidance opt_UF_CreationThreshold expr)
 
 mkUnfolding :: Bool -> CoreExpr -> Unfolding
                  (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
 
                  (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
                  (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 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
                                     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 :: 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
   = 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
   = 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
 
                -- 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
 
     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 "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
                        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,
 
        -- * Properties of expressions
        exprType, coreAltType, coreAltsType,
-       exprIsDupable, exprIsTrivial, exprIsCheap, 
+       exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
        exprIsHNF,exprOkForSpeculation, exprIsBig, 
        exprIsConApp_maybe, exprIsBottom,
        rhsIsStatic,
        exprIsHNF,exprOkForSpeculation, exprIsBig, 
        exprIsConApp_maybe, exprIsBottom,
        rhsIsStatic,
@@ -37,7 +37,7 @@ module CoreUtils (
        hashExpr,
 
        -- * Equality
        hashExpr,
 
        -- * Equality
-       cheapEqExpr, tcEqExpr, tcEqExprX,
+       cheapEqExpr, 
 
        -- * Manipulating data constructors and types
        applyTypeToArgs, applyTypeToArg,
 
        -- * Manipulating data constructors and types
        applyTypeToArgs, applyTypeToArg,
@@ -47,11 +47,9 @@ module CoreUtils (
 #include "HsVersions.h"
 
 import CoreSyn
 #include "HsVersions.h"
 
 import CoreSyn
-import CoreFVs
 import PprCore
 import Var
 import SrcLoc
 import PprCore
 import Var
 import SrcLoc
-import VarSet
 import VarEnv
 import Name
 import Module
 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}
 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
        -- 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.
 
       | 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
   = 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
 
                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
 
                _ -> 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
        
     --------------
        -- 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
  
     --------------
        -- 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)
     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}
 \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,
        -- we are effectively duplicating the unfolding
     analyse (Var fun, [])
        | let unf = idUnfolding fun,
-         isCheapUnfolding unf
+         isExpandableUnfolding unf
        = exprIsConApp_maybe (unfoldingTemplate unf)
 
     analyse _ = Nothing
        = exprIsConApp_maybe (unfoldingTemplate unf)
 
     analyse _ = Nothing
@@ -944,53 +949,6 @@ exprIsBig _            = True
 \end{code}
 
 
 \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
 
     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
 
              (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)
        (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
   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
 
     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
                         ]
 
                         , 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.
 
                -- 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)
 
              _ -> 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
 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
 data IfaceInfoItem
   = HsArity     Arity
   | HsStrictness StrictSig
-  | HsInline     Activation
+  | HsInline     InlinePragma
   | HsUnfold    IfaceExpr
   | HsNoCafRefs
   | HsWorker    Name Arity     -- Worker, if any see IdInfo.WorkerInfo
   | 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)
 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")
   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
        -- 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
 
 --------------------------
 toIfaceIdDetails :: IdDetails -> IfaceIdDetails
@@ -1495,11 +1495,13 @@ toIfaceIdInfo id_info
                                        
     ------------  Inline prag  --------------
     inline_prag = inlinePragInfo 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!
                        -- 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
 
 --------------------------
 coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
index 60fd726..5c78927 100644 (file)
@@ -561,7 +561,7 @@ addExternal (id,rhs) needed
                     spec_ids
 
     idinfo        = idInfo id
                     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)
     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) }
                     { 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)
   "{-#" $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
 
        -- 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
   | 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(..),
 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
 import DynFlags
 import OrdList
 import HaddockParse
@@ -254,6 +254,7 @@ incorrect.
  'using'    { L _ ITusing }     -- for list transform extension
 
  '{-# INLINE'            { L _ (ITinline_prag _) }
  '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 }
  '{-# 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 '#-}'        
        | 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 '#-}'
        | '{-# 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)) }
                                            | 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
 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
 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 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(..),
 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) }
 
 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)
 -- 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"
 
 
 #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 )
 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
        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
                -- 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)
   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
 
                 -- 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
 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
      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 _   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
 
 ------------------
 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
     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
 
                              -> discounts ++ vanilla_discounts
                        _     -> vanilla_discounts
 
@@ -622,9 +622,9 @@ preInlineUnconditionally env top_lvl bndr rhs
   where
     phase = getMode env
     active = case phase of
   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
 
     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
 
   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
 
 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.
 
        -- 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
   where
-    prag = idInlinePragma id
+    act = idInlineActivation id
 
 activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
 -- Nothing => No rules at all
 
 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
         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}
     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
   = 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)
     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 CoreSyn         -- All of it
 import OccurAnal       ( occurAnalyseExpr )
 import CoreFVs         ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars )
-import CoreUtils       ( tcEqExprX, exprType )
+import CoreUtils       ( exprType )
 import PprCore         ( pprRules )
 import PprCore         ( pprRules )
-import Type            ( Type, TvSubstEnv )
+import Type            ( Type, TvSubstEnv, tcEqTypeX )
 import TcType          ( tcSplitTyConApp_maybe )
 import CoreTidy                ( tidyRules )
 import Id
 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
 
 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
   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]
        -- 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)
 
 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'
   = 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)
     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)
     freshly_bound x = not (x `rnInScope` rn_env)
-    bind' = bind
-    e2'   = e2
+    bind'   = bind
+    e2'     = e2
     rn_env' = extendRnInScopeList rn_env bndrs
     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
 
 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 }
 
   = 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
 -- 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) }
 
                                                -- 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
                 -> 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}
 
        ; 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]
 ~~~~~~~~~~~~~~~~~~~~~~
 
 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.
 
 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
 
 \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,
 #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
 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
     (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
 
        -- 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
                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 
                                  (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
 
                -- 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)) } }
                        | 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
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 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,
 
 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 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,
                          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
 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
 
     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,
 import Var
 import Id              ( Id, idType, isOneShotLambda, 
                          setIdNewStrictness, mkWorkerId,
-                         setIdWorkerInfo, setInlinePragma,
+                         setIdWorkerInfo, setInlineActivation,
                          setIdArity, idInfo )
 import MkId            ( lazyIdKey, lazyIdUnfolding )
 import Type            ( Type )
                          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 UniqSupply
 import Unique          ( hasKey )
-import BasicTypes      ( RecFlag(..), isNonRec, isNeverActive )
+import BasicTypes      ( RecFlag(..), isNonRec, isNeverActive,
+                          Activation, inlinePragmaActivation )
 import VarEnv          ( isEmptyVarEnv )
 import Maybes          ( orElse )
 import WwLib
 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
 
   |  -- 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. 
        -- 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
     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) ]
 
   | 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
     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
 
        -- 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)
 
 ---------------------
     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)]
          -> 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
   = 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) 
     ; 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 
                                -- 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
                        `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  = []
        -- 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
                      -- 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