[project @ 2004-11-25 11:36:34 by simonpj]

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

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index f603969..28c913d 100644 (file)
--- 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,
@@ -41,7 +41,7 @@ module CoreSyn (
        -- Core rules
        CoreRules(..),  -- Representation needed by friends
        CoreRule(..),   -- CoreSubst, CoreTidy, CoreFVs, PprCore only
-       IdCoreRule,
+       IdCoreRule(..), isOrphanRule,
        RuleName,
        emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
        isBuiltinRule, ruleName
@@ -78,12 +78,29 @@ data Expr b -- "b" for the type of binders,
   | App   (Expr b) (Arg b)
   | 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
+  -- gaw 2004, added Type field
+  | Case  (Expr b) b Type [Alt b]      -- Binder gets bound to value of scrutinee
+       -- 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
@@ -109,6 +126,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
@@ -167,7 +186,12 @@ rulesRules (Rules rules _) = rules
 
 \begin{code}
 type RuleName = FastString
-type IdCoreRule = (Id,CoreRule)                -- Rules don't have their leading Id inside them
+data IdCoreRule = IdCoreRule Id        -- A rule for this Id
+                            Bool       -- True <=> orphan rule
+                            CoreRule   -- The rule itself
+
+isOrphanRule :: IdCoreRule -> Bool
+isOrphanRule (IdCoreRule _ is_orphan _) = is_orphan
 
 data CoreRule
   = Rule RuleName
@@ -343,12 +367,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)
+
+instance Outputable b => Outputable (TaggedBndr b) where
+  ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
 
-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 => OutputableBndr (TaggedBndr b) where
+  pprBndr _ b = ppr b  -- Simple
 \end{code}
 
 
@@ -530,19 +560,21 @@ valArgCount (other  : args) = 1 + valArgCount args
 
 \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
+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
+-- gaw 2004
+seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `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 (CoreNote s)   = s `seq` ()
 seqNote other         = ()
 
 seqBndr b = b `seq` ()
@@ -583,7 +615,8 @@ data 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]
+-- gaw 2004
+  | AnnCase    (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
   | AnnLet     (AnnBind bndr annot) (AnnExpr bndr annot)
   | AnnNote    Note (AnnExpr bndr annot)
   | AnnType    Type
@@ -612,8 +645,9 @@ deAnnotate' (AnnLet bind body)
     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 
-deAnnotate' (AnnCase scrut v alts)
-  = Case (deAnnotate scrut) v (map deAnnAlt alts)
+-- gaw 2004
+deAnnotate' (AnnCase scrut v t alts)
+  = Case (deAnnotate scrut) v t (map deAnnAlt alts)
 
 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)