X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=a074499fd325b28f26b9559df46fbe73bcc9fcb2;hb=e328afb3e9a9d34b80a8071d5bd7e3f9bff3cf5a;hp=a352829f5f47995ba455b3c0cbefe83d8c5d3b3e;hpb=e0d750bedbd33f7a133c8c82c35fd8db537ab649;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index a352829..a074499 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -7,7 +7,7 @@
 module CoreSyn (
 	Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
 	CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
-	TaggedExpr, TaggedAlt, TaggedBind, TaggedArg,
+	TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
 
 	mkLets, mkLams, 
 	mkApps, mkTyApps, mkValApps, mkVarApps,
@@ -36,7 +36,7 @@ module CoreSyn (
 
 	-- Annotated expressions
 	AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, 
-	deAnnotate, deAnnotate', deAnnAlt,
+	deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
 
 	-- Core rules
 	CoreRules(..), 	-- Representation needed by friends
@@ -54,9 +54,10 @@ 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 DataCon		( DataCon, dataConWorkId )
 import BasicTypes	( Activation )
 import VarSet
+import FastString
 import Outputable
 \end{code}
 
@@ -78,11 +79,27 @@ data Expr b	-- "b" for the type of binders,
   | Lam   b (Expr b)
   | Let   (Bind b) (Expr b)
   | Case  (Expr b) b [Alt b]  	-- Binder gets bound to value of scrutinee
-				-- DEFAULT case must be *first*, if it occurs at all
+	-- Invariant: The list of alternatives is ALWAYS EXHAUSTIVE,
+	--	      meaning that it covers all cases that can occur
+	--	      See the example below
+	--
+	-- Invariant: The DEFAULT case must be *first*, if it occurs at all
   | Note  Note (Expr b)
   | Type  Type			-- This should only show up at the top
 				-- level of an Arg
 
+-- An "exhausive" case does not necessarily mention all constructors:
+--	data Foo = Red | Green | Blue
+--
+--	...case x of 
+--		Red   -> True
+--		other -> f (case x of 
+--				Green -> ...
+--				Blue  -> ... )
+-- The inner case does not need a Red alternative, because x can't be Red at
+-- that program point.
+
+
 type Arg b = Expr b		-- Can be a Type
 
 type Alt b = (AltCon, [b], Expr b)	-- (DEFAULT, [], rhs) is the default alternative
@@ -108,6 +125,8 @@ data Note
   | InlineMe		-- Instructs simplifer to treat the enclosed expression
 			-- as very small, and inline it at its call sites
 
+  | CoreNote String     -- A generic core annotation, propagated but not used by GHC
+
 -- NOTE: we also treat expressions wrapped in InlineMe as
 -- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
 -- What this means is that we obediently inline even things that don't
@@ -165,7 +184,7 @@ rulesRules (Rules rules _) = rules
 \end{code}
 
 \begin{code}
-type RuleName = FAST_STRING
+type RuleName = FastString
 type IdCoreRule = (Id,CoreRule)		-- Rules don't have their leading Id inside them
 
 data CoreRule
@@ -342,12 +361,18 @@ type CoreAlt  = Alt  CoreBndr
 Binders are ``tagged'' with a \tr{t}:
 
 \begin{code}
-type Tagged t = (CoreBndr, t)
+data TaggedBndr t = TB CoreBndr t	-- TB for "tagged binder"
+
+type TaggedBind t = Bind (TaggedBndr t)
+type TaggedExpr t = Expr (TaggedBndr t)
+type TaggedArg  t = Arg  (TaggedBndr t)
+type TaggedAlt  t = Alt  (TaggedBndr t)
 
-type TaggedBind t = Bind (Tagged t)
-type TaggedExpr t = Expr (Tagged t)
-type TaggedArg  t = Arg  (Tagged t)
-type TaggedAlt  t = Alt  (Tagged t)
+instance Outputable b => Outputable (TaggedBndr b) where
+  ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
+
+instance Outputable b => OutputableBndr (TaggedBndr b) where
+  pprBndr _ b = ppr b	-- Simple
 \end{code}
 
 
@@ -376,7 +401,7 @@ mkLets	      :: [Bind b] -> Expr b -> Expr b
 mkLams	      :: [b] -> Expr b -> Expr b
 
 mkLit lit	  = Lit lit
-mkConApp con args = mkApps (Var (dataConId con)) args
+mkConApp con args = mkApps (Var (dataConWorkId con)) args
 
 mkLams binders body = foldr Lam body binders
 mkLets binds body   = foldr Let body binds
@@ -542,6 +567,7 @@ seqExprs [] = ()
 seqExprs (e:es) = seqExpr e `seq` seqExprs es
 
 seqNote (Coerce t1 t2) = seqType t1 `seq` seqType t2
+seqNote (CoreNote s)   = s `seq` ()
 seqNote other	       = ()
 
 seqBndr b = b `seq` ()
@@ -618,3 +644,11 @@ deAnnAlt :: AnnAlt bndr annot -> Alt bndr
 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 \end{code}
 
+\begin{code}
+collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
+collectAnnBndrs e
+  = collect [] e
+  where
+    collect bs (_, AnnLam b body) = collect (b:bs) body
+    collect bs body		  = (reverse bs, body)
+\end{code}