X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreSyn.lhs;h=0a8659ccce9a463d440833a903da412562347f7f;hb=edc0bafd3fcd01b85a2e8894e5dfe149eb0e0857;hp=c74de06b24c822e993025797ca23b904d80b3578;hpb=92267aa26adb1ab5a6d8004a80fdf6aa06ea4e44;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index c74de06..0a8659c 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -4,7 +4,7 @@
 %
 
 \begin{code}
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}
 
 -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection
 module CoreSyn (
@@ -37,9 +37,9 @@ module CoreSyn (
 	notSccNote,
 
 	-- * Unfolding data types
-	Unfolding(..),	UnfoldingGuidance(..), UnfoldingSource(..),
-		-- Abstract everywhere but in CoreUnfold.lhs
-	
+        Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),
+        DFunArg(..), dfunArgExprs,
+
 	-- ** Constructing 'Unfolding's
 	noUnfolding, evaldUnfolding, mkOtherCon,
         unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,
@@ -49,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,
 
@@ -59,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,
 
@@ -67,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
@@ -381,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
@@ -434,10 +437,7 @@ data Unfolding
 
         DataCon 	-- The dictionary data constructor (possibly a newtype datacon)
 
-        [CoreExpr]	-- The [CoreExpr] are the superclasses and methods [op1,op2], 
-			-- in positional order.
-			-- They are usually variables, but can be trivial expressions
-			-- instead (e.g. a type application).  
+        [DFunArg CoreExpr]  -- Specification of superclasses and methods, in positional order
 
   | CoreUnfolding {		-- An unfolding for an Id with no pragma, 
                                 -- or perhaps a NOINLINE pragma
@@ -475,12 +475,42 @@ data Unfolding
   --  uf_guidance:  Tells us about the /size/ of the unfolding template
 
 ------------------------------------------------
-data UnfoldingSource 
+data DFunArg e   -- Given (df a b d1 d2 d3)
+  = DFunPolyArg  e      -- Arg is (e a b d1 d2 d3)
+  | DFunConstArg e      -- Arg is e, which is constant
+  | DFunLamArg   Int    -- Arg is one of [a,b,d1,d2,d3], zero indexed
+  deriving( Functor )
+
+  -- 'e' is often CoreExpr, which are usually variables, but can
+  -- be trivial expressions instead (e.g. a type application).
+
+dfunArgExprs :: [DFunArg e] -> [e]
+dfunArgExprs [] = []
+dfunArgExprs (DFunPolyArg  e : as) = e : dfunArgExprs as
+dfunArgExprs (DFunConstArg e : as) = e : dfunArgExprs as
+dfunArgExprs (DFunLamArg {}  : as) =     dfunArgExprs as
+
+
+------------------------------------------------
+data UnfoldingSource
   = InlineRhs          -- The current rhs of the function
     		       -- Replace uf_tmpl each time around
 
   | InlineStable       -- From an INLINE or INLINABLE pragma 
-    		       -- Do not replace uf_tmpl; instead, keep it unchanged
+                       --   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
@@ -653,15 +683,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
@@ -1142,6 +1167,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