Fix Trac #3409: type synonyms that discard their arguments

[ghc-hetmet.git] / compiler / coreSyn / CoreSyn.lhs

diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index e259591..4d8f3cb 100644 (file)
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -42,7 +42,8 @@ module CoreSyn (
        
        -- ** Predicates and deconstruction on 'Unfolding'
        unfoldingTemplate, maybeUnfoldingTemplate, otherCons, 
-       isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
+       isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
+        isExpandableUnfolding, isCompulsoryUnfolding,
        hasUnfolding, hasSomeUnfolding, neverUnfold,
 
        -- * Strictness
@@ -68,7 +69,6 @@ module CoreSyn (
 
 import CostCentre
 import Var
-import Id
 import Type
 import Coercion
 import Name
@@ -199,7 +199,6 @@ data Expr b
                                        --
                                        -- @
                                         --      data Foo = Red | Green | Blue
-                                        --
                                         -- ... case x of 
                                         --      Red   -> True
                                         --      other -> f (case x of 
@@ -414,6 +413,7 @@ data Unfolding
                Bool
                Bool
                Bool
+                Bool
                UnfoldingGuidance
   -- ^ An unfolding with redundant cached information. Parameters:
   --
@@ -457,8 +457,8 @@ mkOtherCon :: [AltCon] -> Unfolding
 mkOtherCon = OtherCon
 
 seqUnfolding :: Unfolding -> ()
-seqUnfolding (CoreUnfolding e top b1 b2 g)
-  = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
+seqUnfolding (CoreUnfolding e top b1 b2 b3 g)
+  = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` seqGuidance g
 seqUnfolding _ = ()
 
 seqGuidance :: UnfoldingGuidance -> ()
@@ -469,15 +469,15 @@ seqGuidance _                           = ()
 \begin{code}
 -- | Retrieves the template of an unfolding: panics if none is known
 unfoldingTemplate :: Unfolding -> CoreExpr
-unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
-unfoldingTemplate (CompulsoryUnfolding expr)   = expr
+unfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = expr
+unfoldingTemplate (CompulsoryUnfolding expr)     = expr
 unfoldingTemplate _ = panic "getUnfoldingTemplate"
 
 -- | Retrieves the template of an unfolding if possible
 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
-maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
-maybeUnfoldingTemplate (CompulsoryUnfolding expr)   = Just expr
-maybeUnfoldingTemplate _                            = Nothing
+maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = Just expr
+maybeUnfoldingTemplate (CompulsoryUnfolding expr)     = Just expr
+maybeUnfoldingTemplate _                              = Nothing
 
 -- | The constructors that the unfolding could never be: 
 -- returns @[]@ if no information is available
@@ -488,21 +488,25 @@ otherCons _               = []
 -- | Determines if it is certainly the case that the unfolding will
 -- yield a value (something in HNF): returns @False@ if unsure
 isValueUnfolding :: Unfolding -> Bool
-isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
-isValueUnfolding _                                = False
+isValueUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald
+isValueUnfolding _                                  = False
 
 -- | Determines if it possibly the case that the unfolding will
 -- yield a value. Unlike 'isValueUnfolding' it returns @True@
 -- for 'OtherCon'
 isEvaldUnfolding :: Unfolding -> Bool
-isEvaldUnfolding (OtherCon _)                    = True
-isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
-isEvaldUnfolding _                                = False
+isEvaldUnfolding (OtherCon _)                      = True
+isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald
+isEvaldUnfolding _                                  = False
 
 -- | Is the thing we will unfold into certainly cheap?
 isCheapUnfolding :: Unfolding -> Bool
-isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
-isCheapUnfolding _                                = False
+isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _ _) = is_cheap
+isCheapUnfolding _                                  = False
+
+isExpandableUnfolding :: Unfolding -> Bool
+isExpandableUnfolding (CoreUnfolding _ _ _ _ is_expable _) = is_expable
+isExpandableUnfolding _                                    = False
 
 -- | Must this unfolding happen for the code to be executable?
 isCompulsoryUnfolding :: Unfolding -> Bool
@@ -511,9 +515,9 @@ isCompulsoryUnfolding _                       = False
 
 -- | Do we have an available or compulsory unfolding?
 hasUnfolding :: Unfolding -> Bool
-hasUnfolding (CoreUnfolding _ _ _ _ _) = True
-hasUnfolding (CompulsoryUnfolding _)   = True
-hasUnfolding _                         = False
+hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True
+hasUnfolding (CompulsoryUnfolding _)     = True
+hasUnfolding _                           = False
 
 -- | Only returns False if there is no unfolding information available at all
 hasSomeUnfolding :: Unfolding -> Bool
@@ -523,10 +527,10 @@ hasSomeUnfolding _           = True
 -- | Similar to @not . hasUnfolding@, but also returns @True@
 -- if it has an unfolding that says it should never occur
 neverUnfold :: Unfolding -> Bool
-neverUnfold NoUnfolding                                = True
-neverUnfold (OtherCon _)                       = True
-neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
-neverUnfold _                                   = False
+neverUnfold NoUnfolding                                  = True
+neverUnfold (OtherCon _)                         = True
+neverUnfold (CoreUnfolding _ _ _ _ _ UnfoldNever) = True
+neverUnfold _                                     = False
 \end{code}
 
 
@@ -706,7 +710,7 @@ mkTyBind tv ty      = NonRec tv (Type ty)
 
 -- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately
 varToCoreExpr :: CoreBndr -> Expr b
-varToCoreExpr v | isId v    = Var v
+varToCoreExpr v | isId v = Var v
                 | otherwise = Type (mkTyVarTy v)
 
 varsToCoreExprs :: [CoreBndr] -> [Expr b]
@@ -738,7 +742,7 @@ rhssOfAlts :: [Alt b] -> [Expr b]
 rhssOfAlts alts = [e | (_,_,e) <- alts]
 
 -- | Collapse all the bindings in the supplied groups into a single
--- list of lhs/rhs pairs suitable for binding in a 'Rec' binding group
+-- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group
 flattenBinds :: [Bind b] -> [(b, Expr b)]
 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
 flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds