X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=7d2835441790686ecafe015bb5924612995e51f4;hb=1ff7e0c6d3ea0b7db9fe1f9780916fabf9b4cbbd;hp=e87594a5c57d6e96479f3b39562ed8e9cf92c33c;hpb=d133b73a4d4717892ced072d05e039a54ede0ceb;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index e87594a..7d28354 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -5,36 +5,56 @@
 
 \begin{code}
 module CoreSyn (
-	Expr(..), Alt, Bind(..), Arg(..), Note(..),
+	Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
 	CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
 	TaggedExpr, TaggedAlt, TaggedBind, TaggedArg,
 
-	mkLets, mkLetBinds, mkLams,
-	mkApps, mkTyApps, mkValApps,
-	mkLit, mkStringLit, mkConApp, mkPrimApp, mkNote, mkNilExpr,
-	bindNonRec, mkIfThenElse, varToCoreExpr,
+	mkLets, mkLams, 
+	mkApps, mkTyApps, mkValApps, mkVarApps,
+	mkLit, mkIntLitInt, mkIntLit, 
+	mkConApp, 
+	varToCoreExpr,
 
-	bindersOf, rhssOfBind, rhssOfAlts, isDeadBinder, isTyVar, isId,
+	isTyVar, isId, 
+	bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 
 	collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
-	collectArgs,
+	collectArgs, collectBindersIgnoringNotes,
 	coreExprCc,
+	flattenBinds, 
 
-	isValArg, isTypeArg, valArgCount,
+	isValArg, isTypeArg, valArgCount, valBndrCount,
+
+	-- Unfoldings
+	Unfolding(..),	UnfoldingGuidance(..), 	-- Both abstract everywhere but in CoreUnfold.lhs
+	noUnfolding, mkOtherCon,
+	unfoldingTemplate, maybeUnfoldingTemplate, otherCons, 
+	isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
+	hasUnfolding, hasSomeUnfolding, neverUnfold,
+
+	-- Seq stuff
+	seqRules, seqExpr, seqExprs, seqUnfolding,
 
 	-- Annotated expressions
-	AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate
+	AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, 
+	deAnnotate, deAnnotate', deAnnAlt,
+
+	-- Core rules
+	CoreRules(..), 	-- Representation needed by friends
+	CoreRule(..),	-- CoreSubst, CoreTidy, CoreFVs, PprCore only
+	IdCoreRule,
+	RuleName,
+	emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
+	isBuiltinRule
     ) where
 
 #include "HsVersions.h"
 
-import TysWiredIn	( boolTy, stringTy, nilDataCon )
-import CostCentre	( CostCentre, isDupdCC, noCostCentre )
-import Var		( Var, Id, TyVar, IdOrTyVar, isTyVar, isId, idType )
-import Id		( mkWildId, getInlinePragma )
-import Type		( Type, UsageAnn, mkTyVarTy, isUnLiftedType )
-import IdInfo		( InlinePragInfo(..) )
-import Const	        ( Con(..), DataCon, Literal(NoRepStr), PrimOp )
-import TysWiredIn	( trueDataCon, falseDataCon )
+import CostCentre	( CostCentre, noCostCentre )
+import Var		( Var, Id, TyVar, isTyVar, isId )
+import Type		( Type, mkTyVarTy, seqType )
+import Literal	        ( Literal, mkMachInt )
+import DataCon		( DataCon, dataConId )
+import VarSet
 import Outputable
 \end{code}
 
@@ -47,11 +67,11 @@ import Outputable
 These data types are the heart of the compiler
 
 \begin{code}
+infixl 8 `App`	-- App brackets to the left
+
 data Expr b	-- "b" for the type of binders, 
   = Var	  Id
-  | Con   Con [Arg b]		-- Guaranteed saturated
-				-- The Con can be a DataCon, Literal, PrimOP
-				-- but cannot be DEFAULT
+  | Lit   Literal
   | App   (Expr b) (Arg b)
   | Lam   b (Expr b)
   | Let   (Bind b) (Expr b)
@@ -63,9 +83,12 @@ data Expr b	-- "b" for the type of binders,
 
 type Arg b = Expr b		-- Can be a Type
 
-type Alt b = (Con, [b], Expr b)
-	-- (DEFAULT, [], rhs) is the default alternative
-	-- The Con can be a Literal, DataCon, or DEFAULT, but cannot be PrimOp
+type Alt b = (AltCon, [b], Expr b)	-- (DEFAULT, [], rhs) is the default alternative
+
+data AltCon = DataAlt DataCon
+	    | LitAlt  Literal
+	    | DEFAULT
+	 deriving (Eq, Ord)
 
 data Bind b = NonRec b (Expr b)
 	      | Rec [(b, (Expr b))]
@@ -80,8 +103,189 @@ data Note
   | InlineCall		-- Instructs simplifier to inline
 			-- the enclosed call
 
-  | TermUsg             -- A term-level usage annotation
-        UsageAnn        -- (should not be a variable except during UsageSP inference)
+  | InlineMe		-- Instructs simplifer to treat the enclosed expression
+			-- as very small, and inline it at its call sites
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Transformation rules}
+%*									*
+%************************************************************************
+
+The CoreRule type and its friends are dealt with mainly in CoreRules,
+but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
+
+\begin{code}
+data CoreRules 
+  = Rules [CoreRule]
+	  VarSet		-- Locally-defined free vars of RHSs
+
+emptyCoreRules :: CoreRules
+emptyCoreRules = Rules [] emptyVarSet
+
+isEmptyCoreRules :: CoreRules -> Bool
+isEmptyCoreRules (Rules rs _) = null rs
+
+rulesRhsFreeVars :: CoreRules -> VarSet
+rulesRhsFreeVars (Rules _ fvs) = fvs
+
+rulesRules :: CoreRules -> [CoreRule]
+rulesRules (Rules rules _) = rules
+\end{code}
+
+\begin{code}
+type RuleName = FAST_STRING
+type IdCoreRule = (Id,CoreRule)		-- Rules don't have their leading Id inside them
+
+data CoreRule
+  = Rule RuleName
+	 [CoreBndr]	-- Forall'd variables
+	 [CoreExpr]	-- LHS args
+	 CoreExpr	-- RHS
+
+  | BuiltinRule		-- Built-in rules are used for constant folding
+			-- and suchlike.  It has no free variables.
+	([CoreExpr] -> Maybe (RuleName, CoreExpr))
+
+isBuiltinRule (BuiltinRule _) = True
+isBuiltinRule _		      = False
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{@Unfolding@ type}
+%*									*
+%************************************************************************
+
+The @Unfolding@ type is declared here to avoid numerous loops, but it
+should be abstract everywhere except in CoreUnfold.lhs
+
+\begin{code}
+data Unfolding
+  = NoUnfolding
+
+  | OtherCon [AltCon]		-- It ain't one of these
+				-- (OtherCon xs) also indicates that something has been evaluated
+				-- and hence there's no point in re-evaluating it.
+				-- OtherCon [] is used even for non-data-type values
+				-- to indicated evaluated-ness.  Notably:
+				--	data C = C !(Int -> Int)
+				-- 	case x of { C f -> ... }
+				-- Here, f gets an OtherCon [] unfolding.
+
+  | CompulsoryUnfolding CoreExpr	-- There is no "original" definition,
+					-- so you'd better unfold.
+
+  | CoreUnfolding			-- An unfolding with redundant cached information
+		CoreExpr		-- Template; binder-info is correct
+		Bool			-- True <=> top level binding
+		Bool			-- exprIsValue template (cached); it is ok to discard a `seq` on
+					--	this variable
+		Bool			-- True <=> doesn't waste (much) work to expand inside an inlining
+					-- 	Basically it's exprIsCheap
+		UnfoldingGuidance	-- Tells about the *size* of the template.
+
+
+data UnfoldingGuidance
+  = UnfoldNever
+  | UnfoldIfGoodArgs	Int	-- and "n" value args
+
+			[Int]	-- Discount if the argument is evaluated.
+				-- (i.e., a simplification will definitely
+				-- be possible).  One elt of the list per *value* arg.
+
+			Int	-- The "size" of the unfolding; to be elaborated
+				-- later. ToDo
+
+			Int	-- Scrutinee discount: the discount to substract if the thing is in
+				-- a context (case (thing args) of ...),
+				-- (where there are the right number of arguments.)
+
+noUnfolding = NoUnfolding
+mkOtherCon  = OtherCon
+
+seqUnfolding :: Unfolding -> ()
+seqUnfolding (CoreUnfolding e top b1 b2 g)
+  = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
+seqUnfolding other = ()
+
+seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
+seqGuidance other			= ()
+\end{code}
+
+\begin{code}
+unfoldingTemplate :: Unfolding -> CoreExpr
+unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
+unfoldingTemplate (CompulsoryUnfolding expr)   = expr
+unfoldingTemplate other = panic "getUnfoldingTemplate"
+
+maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
+maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
+maybeUnfoldingTemplate (CompulsoryUnfolding expr)   = Just expr
+maybeUnfoldingTemplate other 			    = Nothing
+
+otherCons :: Unfolding -> [AltCon]
+otherCons (OtherCon cons) = cons
+otherCons other		  = []
+
+isValueUnfolding :: Unfolding -> Bool
+	-- Returns False for OtherCon
+isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
+isValueUnfolding other			          = False
+
+isEvaldUnfolding :: Unfolding -> Bool
+	-- Returns True for OtherCon
+isEvaldUnfolding (OtherCon _)		          = True
+isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
+isEvaldUnfolding other			          = False
+
+isCheapUnfolding :: Unfolding -> Bool
+isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
+isCheapUnfolding other			  	  = False
+
+isCompulsoryUnfolding :: Unfolding -> Bool
+isCompulsoryUnfolding (CompulsoryUnfolding _) = True
+isCompulsoryUnfolding other		      = False
+
+hasUnfolding :: Unfolding -> Bool
+hasUnfolding (CoreUnfolding _ _ _ _ _) = True
+hasUnfolding (CompulsoryUnfolding _)   = True
+hasUnfolding other 	 	       = False
+
+hasSomeUnfolding :: Unfolding -> Bool
+hasSomeUnfolding NoUnfolding = False
+hasSomeUnfolding other	     = True
+
+neverUnfold :: Unfolding -> Bool
+neverUnfold NoUnfolding				= True
+neverUnfold (OtherCon _)			= True
+neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
+neverUnfold other 				= False
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{The main data type}
+%*									*
+%************************************************************************
+
+\begin{code}
+-- The Ord is needed for the FiniteMap used in the lookForConstructor
+-- in SimplEnv.  If you declared that lookForConstructor *ignores*
+-- constructor-applications with LitArg args, then you could get
+-- rid of this Ord.
+
+instance Outputable AltCon where
+  ppr (DataAlt dc) = ppr dc
+  ppr (LitAlt lit) = ppr lit
+  ppr DEFAULT      = ptext SLIT("__DEFAULT")
+
+instance Show AltCon where
+  showsPrec p con = showsPrecSDoc p (ppr con)
 \end{code}
 
 
@@ -94,12 +298,11 @@ data Note
 The common case
 
 \begin{code}
-type CoreBndr = IdOrTyVar
+type CoreBndr = Var
 type CoreExpr = Expr CoreBndr
 type CoreArg  = Arg  CoreBndr
 type CoreBind = Bind CoreBndr
 type CoreAlt  = Alt  CoreBndr
-type CoreNote = Note
 \end{code}
 
 Binders are ``tagged'' with a \tr{t}:
@@ -124,85 +327,34 @@ type TaggedAlt  t = Alt  (Tagged t)
 mkApps    :: Expr b -> [Arg b]  -> Expr b
 mkTyApps  :: Expr b -> [Type]   -> Expr b
 mkValApps :: Expr b -> [Expr b] -> Expr b
+mkVarApps :: Expr b -> [Var] -> Expr b
 
 mkApps    f args = foldl App		  	   f args
 mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
 mkValApps f args = foldl (\ e a -> App e a)	   f args
+mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
+
+mkLit         :: Literal -> Expr b
+mkIntLit      :: Integer -> Expr b
+mkIntLitInt   :: Int     -> Expr b
+mkConApp      :: DataCon -> [Arg b] -> Expr b
+mkLets	      :: [Bind b] -> Expr b -> Expr b
+mkLams	      :: [b] -> Expr b -> Expr b
 
-mkLit       :: Literal -> Expr b
-mkStringLit :: String  -> Expr b
-mkConApp    :: DataCon -> [Arg b] -> Expr b
-mkPrimApp   :: PrimOp  -> [Arg b] -> Expr b
+mkLit lit	  = Lit lit
+mkConApp con args = mkApps (Var (dataConId con)) args
 
-mkLit lit	  = Con (Literal lit) []
-mkStringLit str	  = Con (Literal (NoRepStr (_PK_ str) stringTy)) []
-mkConApp con args = Con (DataCon con) args
-mkPrimApp op args = Con (PrimOp op)   args
+mkLams binders body = foldr Lam body binders
+mkLets binds body   = foldr Let body binds
 
-mkNilExpr :: Type -> CoreExpr
-mkNilExpr ty = Con (DataCon nilDataCon) [Type ty]
+mkIntLit    n = Lit (mkMachInt n)
+mkIntLitInt n = Lit (mkMachInt (toInteger n))
 
-varToCoreExpr :: CoreBndr -> CoreExpr
+varToCoreExpr :: CoreBndr -> Expr b
 varToCoreExpr v | isId v    = Var v
                 | otherwise = Type (mkTyVarTy v)
 \end{code}
 
-\begin{code}
-mkLams :: [b] -> Expr b -> Expr b
-mkLams binders body = foldr Lam body binders
-\end{code}
-
-\begin{code}
-mkLets :: [Bind b] -> Expr b -> Expr b
-mkLets binds body = foldr Let body binds
-
-mkLetBinds :: [CoreBind] -> CoreExpr -> CoreExpr
--- mkLetBinds is like mkLets, but it uses bindNonRec to 
--- make a case binding for unlifted things
-mkLetBinds []                   body = body
-mkLetBinds (NonRec b r : binds) body = bindNonRec b r (mkLetBinds binds body)
-mkLetBinds (bind       : binds) body = Let bind (mkLetBinds binds body)
-
-bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
--- (bindNonRec x r b) produces either
---	let x = r in b
--- or
---	case r of x { _DEFAULT_ -> b }
---
--- depending on whether x is unlifted or not
-bindNonRec bndr rhs body
-  | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
-  | otherwise			 = Let (NonRec bndr rhs) body
-
-mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
-mkIfThenElse guard then_expr else_expr
-  = Case guard (mkWildId boolTy) 
-	 [ (DataCon trueDataCon,  [], then_expr),
-	   (DataCon falseDataCon, [], else_expr) ]
-\end{code}
-
-mkNote removes redundant coercions, and SCCs where possible
-
-\begin{code}
-mkNote :: Note -> Expr b -> Expr b
-mkNote (Coerce to_ty1 from_ty1) (Note (Coerce to_ty2 from_ty2) expr)
- = ASSERT( from_ty1 == to_ty2 )
-   mkNote (Coerce to_ty1 from_ty2) expr
-
-mkNote (SCC cc1) expr@(Note (SCC cc2) _)
-  | isDupdCC cc1	-- Discard the outer SCC provided we don't need
-  = expr		-- to track its entry count
-
-mkNote note@(SCC cc1) expr@(Lam x e)	-- Move _scc_ inside lambda
-  = Lam x (mkNote note e)
-
--- Slide InlineCall in around the function
-mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
-mkNote InlineCall (Var v)   = Note InlineCall (Var v)
-mkNote InlineCall expr      = expr
-
-mkNote note expr = Note note expr
-\end{code}
 
 %************************************************************************
 %*									*
@@ -215,6 +367,9 @@ bindersOf  :: Bind b -> [b]
 bindersOf (NonRec binder _) = [binder]
 bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
 
+bindersOfBinds :: [Bind b] -> [b]
+bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
+
 rhssOfBind :: Bind b -> [Expr b]
 rhssOfBind (NonRec _ rhs) = [rhs]
 rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
@@ -222,11 +377,10 @@ rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
 rhssOfAlts :: [Alt b] -> [Expr b]
 rhssOfAlts alts = [e | (_,_,e) <- alts]
 
-isDeadBinder :: CoreBndr -> Bool
-isDeadBinder bndr | isId bndr = case getInlinePragma bndr of
-					IAmDead -> True
-					other	-> False
-		  | otherwise = False	-- TyVars count as not dead
+flattenBinds :: [Bind b] -> [(b, Expr b)]	-- Get all the lhs/rhs pairs
+flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
+flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
+flattenBinds []			  = []
 \end{code}
 
 We often want to strip off leading lambdas before getting down to
@@ -236,10 +390,27 @@ We expect (by convention) type-, and value- lambdas in that
 order.
 
 \begin{code}
-collectBinders	       :: Expr b -> ([b],         Expr b)
-collectTyBinders       :: CoreExpr -> ([TyVar],     CoreExpr)
-collectValBinders      :: CoreExpr -> ([Id],        CoreExpr)
-collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
+collectBinders	             :: Expr b -> ([b],         Expr b)
+collectBindersIgnoringNotes  :: Expr b -> ([b],         Expr b)
+collectTyBinders       	     :: CoreExpr -> ([TyVar],     CoreExpr)
+collectValBinders      	     :: CoreExpr -> ([Id],        CoreExpr)
+collectTyAndValBinders 	     :: CoreExpr -> ([TyVar], [Id], CoreExpr)
+
+collectBinders expr
+  = go [] expr
+  where
+    go bs (Lam b e) = go (b:bs) e
+    go bs e	     = (reverse bs, e)
+
+-- This one ignores notes.  It's used in CoreUnfold and StrAnal
+-- when we aren't going to put the expression back together from
+-- the pieces, so we don't mind losing the Notes
+collectBindersIgnoringNotes expr
+  = go [] expr
+  where
+    go bs (Lam b e)  = go (b:bs) e
+    go bs (Note _ e) = go    bs  e
+    go bs e	     = (reverse bs, e)
 
 collectTyAndValBinders expr
   = (tvs, ids, body)
@@ -247,12 +418,6 @@ collectTyAndValBinders expr
     (tvs, body1) = collectTyBinders expr
     (ids, body)  = collectValBinders body1
 
-collectBinders expr
-  = go [] expr
-  where
-    go tvs (Lam b e) = go (b:tvs) e
-    go tvs e	     = (reverse tvs, e)
-
 collectTyBinders expr
   = go [] expr
   where
@@ -304,6 +469,11 @@ isValArg other    = True
 isTypeArg (Type _) = True
 isTypeArg other    = False
 
+valBndrCount :: [CoreBndr] -> Int
+valBndrCount []		    	  = 0
+valBndrCount (b : bs) | isId b    = 1 + valBndrCount bs
+		      | otherwise = valBndrCount bs
+
 valArgCount :: [Arg b] -> Int
 valArgCount []		    = 0
 valArgCount (Type _ : args) = valArgCount args
@@ -313,6 +483,53 @@ valArgCount (other  : args) = 1 + valArgCount args
 
 %************************************************************************
 %*									*
+\subsection{Seq stuff}
+%*									*
+%************************************************************************
+
+\begin{code}
+seqExpr :: CoreExpr -> ()
+seqExpr (Var v)       = v `seq` ()
+seqExpr (Lit lit)     = lit `seq` ()
+seqExpr (App f a)     = seqExpr f `seq` seqExpr a
+seqExpr (Lam b e)     = seqBndr b `seq` seqExpr e
+seqExpr (Let b e)     = seqBind b `seq` seqExpr e
+seqExpr (Case e b as) = seqExpr e `seq` seqBndr b `seq` seqAlts as
+seqExpr (Note n e)    = seqNote n `seq` seqExpr e
+seqExpr (Type t)      = seqType t
+
+seqExprs [] = ()
+seqExprs (e:es) = seqExpr e `seq` seqExprs es
+
+seqNote (Coerce t1 t2) = seqType t1 `seq` seqType t2
+seqNote other	       = ()
+
+seqBndr b = b `seq` ()
+
+seqBndrs [] = ()
+seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
+
+seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
+seqBind (Rec prs)    = seqPairs prs
+
+seqPairs [] = ()
+seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
+
+seqAlts [] = ()
+seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
+
+seqRules :: CoreRules -> ()
+seqRules (Rules rules fvs) = seq_rules rules `seq` seqVarSet fvs
+
+seq_rules [] = ()
+seq_rules (Rule fs bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules
+seq_rules (BuiltinRule _ : rules) = seq_rules rules
+\end{code}
+
+
+
+%************************************************************************
+%*									*
 \subsection{Annotated core; annotation at every node in the tree}
 %*									*
 %************************************************************************
@@ -322,7 +539,7 @@ type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
 
 data AnnExpr' bndr annot
   = AnnVar	Id
-  | AnnCon	Con [AnnExpr bndr annot]
+  | AnnLit	Literal
   | AnnLam	bndr (AnnExpr bndr annot)
   | AnnApp	(AnnExpr bndr annot) (AnnExpr bndr annot)
   | AnnCase	(AnnExpr bndr annot) bndr [AnnAlt bndr annot]
@@ -330,7 +547,7 @@ data AnnExpr' bndr annot
   | AnnNote	Note (AnnExpr bndr annot)
   | AnnType	Type
 
-type AnnAlt bndr annot = (Con, [bndr], AnnExpr bndr annot)
+type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
 
 data AnnBind bndr annot
   = AnnNonRec bndr (AnnExpr bndr annot)
@@ -339,23 +556,25 @@ data AnnBind bndr annot
 
 \begin{code}
 deAnnotate :: AnnExpr bndr annot -> Expr bndr
+deAnnotate (_, e) = deAnnotate' e
 
-deAnnotate (_, AnnType	t)          = Type t
-deAnnotate (_, AnnVar	v)          = Var v
-deAnnotate (_, AnnCon	con args)   = Con con (map deAnnotate args)
-deAnnotate (_, AnnLam	binder body)= Lam binder (deAnnotate body)
-deAnnotate (_, AnnApp	fun arg)    = App (deAnnotate fun) (deAnnotate arg)
-deAnnotate (_, AnnNote	note body)  = Note note (deAnnotate body)
+deAnnotate' (AnnType t)           = Type t
+deAnnotate' (AnnVar  v)           = Var v
+deAnnotate' (AnnLit  lit)         = Lit lit
+deAnnotate' (AnnLam  binder body) = Lam binder (deAnnotate body)
+deAnnotate' (AnnApp  fun arg)     = App (deAnnotate fun) (deAnnotate arg)
+deAnnotate' (AnnNote note body)   = Note note (deAnnotate body)
 
-deAnnotate (_, AnnLet bind body)
+deAnnotate' (AnnLet bind body)
   = Let (deAnnBind bind) (deAnnotate body)
   where
     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 
-deAnnotate (_, AnnCase scrut v alts)
+deAnnotate' (AnnCase scrut v alts)
   = Case (deAnnotate scrut) v (map deAnnAlt alts)
-  where
-    deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
+
+deAnnAlt :: AnnAlt bndr annot -> Alt bndr
+deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 \end{code}