X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreSyn.lhs;h=2dda733a7acce42360b1e8b754a05a89a1593044;hb=aa1c7df20292d9af0b757d71870ae6890a1f9030;hp=05cc575f97b5bb4ead806e966bf315acaaac1950;hpb=a51fe79ebcdcb8285573a18f12cade2101533419;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 05cc575..2dda733 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -34,6 +34,7 @@ module CoreSyn (
 	collectArgs, coreExprCc, flattenBinds, 
 
 	isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
+	notSccNote,
 
 	-- * Unfolding data types
 	Unfolding(..),	UnfoldingGuidance(..), UnfoldingSource(..),
@@ -48,7 +49,7 @@ module CoreSyn (
 	maybeUnfoldingTemplate, otherCons, unfoldingArity,
 	isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
-	isStableUnfolding, isStableUnfolding_maybe, 
+        isStableUnfolding, isStableCoreUnfolding_maybe,
         isClosedUnfolding, hasSomeUnfolding, 
 	canUnfold, neverUnfoldGuidance, isStableSource,
 
@@ -58,6 +59,9 @@ module CoreSyn (
 	-- * Annotated expression data types
 	AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
 	
+        -- ** Operations on annotated expressions
+        collectAnnArgs,
+
 	-- ** Operations on annotations
 	deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
 
@@ -66,7 +70,7 @@ module CoreSyn (
 	RuleName, IdUnfoldingFun,
 	
 	-- ** Operations on 'CoreRule's 
-	seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe,
+	seqRules, ruleArity, ruleName, ruleIdName, ruleActivation,
 	setRuleIdName,
 	isBuiltinRule, isLocalRule
     ) where
@@ -318,7 +322,7 @@ data CoreRule
   = Rule { 
 	ru_name :: RuleName,            -- ^ Name of the rule, for communication with the user
 	ru_act  :: Activation,          -- ^ When the rule is active
-	
+
 	-- Rough-matching stuff
 	-- see comments with InstEnv.Instance( is_cls, is_rough )
 	ru_fn    :: Name,	        -- ^ Name of the 'Id.Id' at the head of this rule
@@ -335,6 +339,10 @@ data CoreRule
 					-- See Note [OccInfo in unfoldings and rules]
 
 	-- Locality
+        ru_auto :: Bool,	-- ^ @True@  <=> this rule is auto-generated
+		   		--   @False@ <=> generated at the users behest
+				--   Main effect: reporting of orphan-hood
+
 	ru_local :: Bool	-- ^ @True@ iff the fn at the head of the rule is
 				-- defined in the same module as the rule
 				-- and is not an implicit 'Id' (like a record selector,
@@ -376,9 +384,9 @@ ruleArity (Rule {ru_args = args})      = length args
 ruleName :: CoreRule -> RuleName
 ruleName = ru_name
 
-ruleActivation_maybe :: CoreRule -> Maybe Activation
-ruleActivation_maybe (BuiltinRule { })       = Nothing
-ruleActivation_maybe (Rule { ru_act = act }) = Just act
+ruleActivation :: CoreRule -> Activation
+ruleActivation (BuiltinRule { })       = AlwaysActive
+ruleActivation (Rule { ru_act = act }) = act
 
 -- | The 'Name' of the 'Id.Id' at the head of the rule left hand side
 ruleIdName :: CoreRule -> Name
@@ -475,7 +483,20 @@ data UnfoldingSource
     		       -- Replace uf_tmpl each time around
 
   | InlineStable       -- From an INLINE or INLINABLE pragma 
-    		       -- Do not replace uf_tmpl; instead, keep it unchanged
+                       --   INLINE     if guidance is UnfWhen
+                       --   INLINABLE  if guidance is UnfIfGoodArgs
+                       -- (well, technically an INLINABLE might be made
+                       -- UnfWhen if it was small enough, and then
+                       -- it will behave like INLINE outside the current
+                       -- module, but that is the way automatic unfoldings
+                       -- work so it is consistent with the intended
+                       -- meaning of INLINABLE).
+                       --
+    		       -- uf_tmpl may change, but only as a result of
+                       -- gentle simplification, it doesn't get updated
+                       -- to the current RHS during compilation as with
+                       -- InlineRhs.
+                       --
     		       -- See Note [InlineRules]
 
   | InlineCompulsory   -- Something that *has* no binding, so you *must* inline it
@@ -648,15 +669,10 @@ expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr
 expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
 expandUnfolding_maybe _                                                       = Nothing
 
-isStableUnfolding_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool)
-isStableUnfolding_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide }) 
-   | isStableSource src
-   = Just (src, unsat_ok)
-   where
-     unsat_ok = case guide of
-     	      	  UnfWhen unsat_ok _ -> unsat_ok
-                  _                  -> needSaturated
-isStableUnfolding_maybe _ = Nothing
+isStableCoreUnfolding_maybe :: Unfolding -> Maybe UnfoldingSource
+isStableCoreUnfolding_maybe (CoreUnfolding { uf_src = src })
+   | isStableSource src   = Just src
+isStableCoreUnfolding_maybe _ = Nothing
 
 isCompulsoryUnfolding :: Unfolding -> Bool
 isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
@@ -1046,6 +1062,10 @@ valBndrCount = count isId
 -- | The number of argument expressions that are values rather than types at their top level
 valArgCount :: [Arg b] -> Int
 valArgCount = count isValArg
+
+notSccNote :: Note -> Bool
+notSccNote (SCC {}) = False
+notSccNote _        = True
 \end{code}
 
 
@@ -1133,6 +1153,17 @@ data AnnBind bndr annot
 \end{code}
 
 \begin{code}
+-- | Takes a nested application expression and returns the the function
+-- being applied and the arguments to which it is applied
+collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a])
+collectAnnArgs expr
+  = go expr []
+  where
+    go (_, AnnApp f a) as = go f (a:as)
+    go e 	       as = (e, as)
+\end{code}
+
+\begin{code}
 deAnnotate :: AnnExpr bndr annot -> Expr bndr
 deAnnotate (_, e) = deAnnotate' e