X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FBasicTypes.lhs;h=f14ab4d98ceeb84a4cf4d25cccdaad78db1860a2;hb=011680bdbd73c93f6fd8363aaef93f995ba8f5b1;hp=9b21399c48e31f5295dddbca96efcd334d92c505;hpb=72462499b891d5779c19f3bda03f96e24f9554ae;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index 9b21399..f14ab4d 100644
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -42,8 +42,9 @@ module BasicTypes(
 
 	TupCon(..), tupleParens,
 
-	OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc, 
+	OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc, 
 	isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc,
+        nonRuleLoopBreaker,
 
 	InsideLam, insideLam, notInsideLam,
 	OneBranch, oneBranch, notOneBranch,
@@ -56,8 +57,8 @@ module BasicTypes(
 	CompilerPhase, 
 	Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
         RuleMatchInfo(..), isConLike, isFunLike, 
-        InlinePragma(..), defaultInlinePragma, neverInlinePragma, dfunInlinePragma,
-	isDefaultInlinePragma, isInlinePragma,
+        InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma,
+	isDefaultInlinePragma, isInlinePragma, inlinePragmaSat,
         inlinePragmaActivation, inlinePragmaRuleMatchInfo,
         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
 
@@ -476,17 +477,20 @@ isNonRuleLoopBreaker :: OccInfo -> Bool
 isNonRuleLoopBreaker (IAmALoopBreaker False) = True   -- Loop-breaker that breaks a non-rule cycle
 isNonRuleLoopBreaker _                       = False
 
+nonRuleLoopBreaker :: OccInfo
+nonRuleLoopBreaker = IAmALoopBreaker False
+
 isDeadOcc :: OccInfo -> Bool
 isDeadOcc IAmDead = True
 isDeadOcc _       = False
 
 isOneOcc :: OccInfo -> Bool
-isOneOcc (OneOcc _ _ _) = True
-isOneOcc _              = False
+isOneOcc (OneOcc {}) = True
+isOneOcc _           = False
 
-isFragileOcc :: OccInfo -> Bool
-isFragileOcc (OneOcc _ _ _) = True
-isFragileOcc _              = False
+zapFragileOcc :: OccInfo -> OccInfo
+zapFragileOcc (OneOcc {}) = NoOccInfo
+zapFragileOcc occ         = occ
 \end{code}
 
 \begin{code}
@@ -593,6 +597,8 @@ data InlinePragma  	     -- Note [InlinePragma]
   = InlinePragma
       { inl_inline :: Bool           -- True <=> INLINE, 
       		      		     -- False <=> no pragma at all, or NOINLINE
+      , inl_sat    :: Maybe Arity    -- Just n <=> Inline only when applied to n 
+      		      	    	     --            explicit (non-type, non-dictionary) args
       , inl_act    :: Activation     -- Says during which phases inlining is allowed
       , inl_rule   :: RuleMatchInfo  -- Should the function be treated like a constructor?
     } deriving( Eq )
@@ -611,6 +617,8 @@ If you write nothing at all, you get defaultInlinePragma:
 It's not possible to get that combination by *writing* something, so 
 if an Id has defaultInlinePragma it means the user didn't specify anything.
 
+If inl_inline = True, then the Id should have an InlineRule unfolding.
+
 Note [CONLIKE pragma]
 ~~~~~~~~~~~~~~~~~~~~~
 The ConLike constructor of a RuleMatchInfo is aimed at the following.
@@ -656,14 +664,22 @@ isFunLike :: RuleMatchInfo -> Bool
 isFunLike FunLike = True
 isFunLike _            = False
 
-defaultInlinePragma, neverInlinePragma, dfunInlinePragma :: InlinePragma
-defaultInlinePragma 
-  = InlinePragma { inl_act = AlwaysActive, inl_rule = FunLike, inl_inline = False }
-neverInlinePragma   
-   = InlinePragma { inl_act = NeverActive, inl_rule = FunLike, inl_inline = False }
-dfunInlinePragma   
-   = InlinePragma { inl_act = AlwaysActive, inl_rule = ConLike, inl_inline = False }
-                                    
+defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
+  :: InlinePragma
+defaultInlinePragma = InlinePragma { inl_act = AlwaysActive
+                                   , inl_rule = FunLike
+                                   , inl_inline = False
+                                   , inl_sat = Nothing }
+
+alwaysInlinePragma = defaultInlinePragma { inl_inline = True }
+neverInlinePragma  = defaultInlinePragma { inl_act    = NeverActive }
+
+-- A DFun has an always-active inline activation so that 
+-- exprIsConApp_maybe can "see" its unfolding
+-- (However, its actual Unfolding is a DFunUnfolding, which is
+--  never inlined other than via exprIsConApp_maybe.)
+dfunInlinePragma   = defaultInlinePragma { inl_act  = AlwaysActive
+                                         , inl_rule = ConLike }
 
 isDefaultInlinePragma :: InlinePragma -> Bool
 isDefaultInlinePragma (InlinePragma { inl_act = activation
@@ -674,6 +690,9 @@ isDefaultInlinePragma (InlinePragma { inl_act = activation
 isInlinePragma :: InlinePragma -> Bool
 isInlinePragma prag = inl_inline prag
 
+inlinePragmaSat :: InlinePragma -> Maybe Arity
+inlinePragmaSat = inl_sat
+
 inlinePragmaActivation :: InlinePragma -> Activation
 inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation
 
@@ -687,8 +706,8 @@ setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
 setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }
 
 instance Outputable Activation where
-   ppr AlwaysActive     = ptext (sLit "ALWAYS")
-   ppr NeverActive      = ptext (sLit "NEVER")
+   ppr AlwaysActive     = brackets (ptext (sLit "ALWAYS"))
+   ppr NeverActive      = brackets (ptext (sLit "NEVER"))
    ppr (ActiveBefore n) = brackets (char '~' <> int n)
    ppr (ActiveAfter n)  = brackets (int n)
 
@@ -697,17 +716,20 @@ instance Outputable RuleMatchInfo where
    ppr FunLike = ptext (sLit "FUNLIKE")
 
 instance Outputable InlinePragma where
-  ppr (InlinePragma { inl_inline = inline, inl_act = activation, inl_rule = info })
-    = pp_inline <+> pp_info <+> pp_activation
+  ppr (InlinePragma { inl_inline = inline, inl_act = activation
+                    , inl_rule = info, inl_sat = mb_arity })
+    = pp_inl_act (inline, activation) <+> pp_sat <+> pp_info 
     where
-      pp_inline | inline    = ptext (sLit "INLINE")
-                | otherwise = ptext (sLit "NOINLINE")
+      pp_inl_act (False, AlwaysActive)  = empty	-- defaultInlinePragma
+      pp_inl_act (False, NeverActive)   = ptext (sLit "NOINLINE")
+      pp_inl_act (False, act)           = ptext (sLit "NOINLINE") <> ppr act
+      pp_inl_act (True,  AlwaysActive)  = ptext (sLit "INLINE")
+      pp_inl_act (True,  act)           = ptext (sLit "INLINE") <> ppr act
+
+      pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> int ar)
+             | otherwise           = empty
       pp_info | isFunLike info = empty
               | otherwise      = ppr info
-      pp_activation 
-        | inline     && isAlwaysActive activation = empty
-        | not inline && isNeverActive  activation = empty
-        | otherwise                               = ppr activation    
 
 isActive :: CompilerPhase -> Activation -> Bool
 isActive _ NeverActive      = False