projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Wibble in HscMain.
[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreSyn.lhs
diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 83ef923..201d866 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,
 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,
 
        mkLets, mkLams, 
        mkApps, mkTyApps, mkValApps, mkVarApps,
@@ -15,10 +15,10 @@ module CoreSyn (
        mkConApp, 
        varToCoreExpr,
 
        mkConApp, 
        varToCoreExpr,
 
-       isTyVar, isId, 
+       isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
        bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 
        collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
        bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 
        collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
-       collectArgs, collectBindersIgnoringNotes,
+       collectArgs, 
        coreExprCc,
        flattenBinds, 
 
        coreExprCc,
        flattenBinds, 
 
@@ -26,36 +26,36 @@ module CoreSyn (
 
        -- Unfoldings
        Unfolding(..),  UnfoldingGuidance(..),  -- Both abstract everywhere but in CoreUnfold.lhs
 
        -- Unfoldings
        Unfolding(..),  UnfoldingGuidance(..),  -- Both abstract everywhere but in CoreUnfold.lhs
-       noUnfolding, mkOtherCon,
+       noUnfolding, evaldUnfolding, mkOtherCon,
        unfoldingTemplate, maybeUnfoldingTemplate, otherCons, 
        isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
        hasUnfolding, hasSomeUnfolding, neverUnfold,
 
        -- Seq stuff
        unfoldingTemplate, maybeUnfoldingTemplate, otherCons, 
        isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
        hasUnfolding, hasSomeUnfolding, neverUnfold,
 
        -- Seq stuff
-       seqRules, seqExpr, seqExprs, seqUnfolding,
+       seqExpr, seqExprs, seqUnfolding, 
 
        -- Annotated expressions
        AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, 
 
        -- Annotated expressions
        AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, 
-       deAnnotate, deAnnotate', deAnnAlt,
+       deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
 
        -- Core rules
 
        -- Core rules
-       CoreRules(..),  -- Representation needed by friends
        CoreRule(..),   -- CoreSubst, CoreTidy, CoreFVs, PprCore only
        CoreRule(..),   -- CoreSubst, CoreTidy, CoreFVs, PprCore only
-       IdCoreRule,
-       RuleName,
-       emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
-       isBuiltinRule, ruleName
+       RuleName, seqRules, 
+       isBuiltinRule, ruleName, isLocalRule, ruleIdName
     ) where
 
 #include "HsVersions.h"
 
     ) where
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( opt_RuntimeTypes )
+import StaticFlags     ( opt_RuntimeTypes )
 import CostCentre      ( CostCentre, noCostCentre )
 import Var             ( Var, Id, TyVar, isTyVar, isId )
 import Type            ( Type, mkTyVarTy, seqType )
 import CostCentre      ( CostCentre, noCostCentre )
 import Var             ( Var, Id, TyVar, isTyVar, isId )
 import Type            ( Type, mkTyVarTy, seqType )
+import Name            ( Name )
+import OccName         ( OccName )
 import Literal         ( Literal, mkMachInt )
 import Literal         ( Literal, mkMachInt )
-import DataCon         ( DataCon, dataConId )
-import VarSet
+import DataCon         ( DataCon, dataConWorkId, dataConTag )
+import BasicTypes      ( Activation )
+import FastString
 import Outputable
 \end{code}
 
 import Outputable
 \end{code}
 
@@ -76,12 +76,33 @@ data Expr b -- "b" for the type of binders,
   | App   (Expr b) (Arg b)
   | Lam   b (Expr b)
   | Let   (Bind b) (Expr b)
   | 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
+  | 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
+       -- Invariant: The remaining cases are in order of increasing 
+       --              tag     (for DataAlts)
+       --              lit     (for LitAlts)
+       --            This makes finding the relevant constructor easy,
+       --            and makes comparison easier too
   | Note  Note (Expr b)
   | Type  Type                 -- This should only show up at the top
                                -- level of an Arg
 
   | 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
 type Arg b = Expr b            -- Can be a Type
 
 type Alt b = (AltCon, [b], Expr b)     -- (DEFAULT, [], rhs) is the default alternative
@@ -91,6 +112,7 @@ data AltCon = DataAlt DataCon
            | DEFAULT
         deriving (Eq, Ord)
 
            | DEFAULT
         deriving (Eq, Ord)
 
+
 data Bind b = NonRec b (Expr b)
              | Rec [(b, (Expr b))]
 
 data Bind b = NonRec b (Expr b)
              | Rec [(b, (Expr b))]
 
@@ -107,6 +129,8 @@ data Note
   | InlineMe           -- Instructs simplifer to treat the enclosed expression
                        -- as very small, and inline it at its call sites
 
   | 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
 -- 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
@@ -145,50 +169,65 @@ INVARIANTS:
 The CoreRule type and its friends are dealt with mainly in CoreRules,
 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
 
 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
+A Rule is 
 
 
-isEmptyCoreRules :: CoreRules -> Bool
-isEmptyCoreRules (Rules rs _) = null rs
+  "local"  if the function it is a rule for is defined in the
+          same module as the rule itself.
 
 
-rulesRhsFreeVars :: CoreRules -> VarSet
-rulesRhsFreeVars (Rules _ fvs) = fvs
-
-rulesRules :: CoreRules -> [CoreRule]
-rulesRules (Rules rules _) = rules
-\end{code}
+  "orphan" if nothing on the LHS is defined in the same module
+          as the rule itself
 
 \begin{code}
 
 \begin{code}
-type RuleName = FAST_STRING
-type IdCoreRule = (Id,CoreRule)                -- Rules don't have their leading Id inside them
+type RuleName = FastString
 
 data CoreRule
 
 data CoreRule
-  = Rule RuleName
-        [CoreBndr]     -- Forall'd variables
-        [CoreExpr]     -- LHS args
-        CoreExpr       -- RHS
+  = Rule { 
+       ru_name :: RuleName,
+       ru_act  :: Activation,  -- When the rule is active
+       
+       -- Rough-matching stuff
+       -- see comments with InstEnv.Instance( is_cls, is_rough )
+       ru_fn    :: Name,       -- Name of the Id at the head of this rule
+       ru_rough :: [Maybe Name],       -- Name at the head of each argument
+       
+       -- Proper-matching stuff
+       -- see comments with InstEnv.Instance( is_tvs, is_tys )
+       ru_bndrs :: [CoreBndr], -- Forall'd variables
+       ru_args  :: [CoreExpr], -- LHS args
+       
+       -- And the right-hand side
+       ru_rhs   :: CoreExpr,
+
+       -- Locality
+       ru_local :: Bool,       -- The fn at the head of the rule is
+                               -- defined in the same module as the rule
+
+       -- Orphan-hood; see comments is InstEnv.Instance( is_orph )
+       ru_orph  :: Maybe OccName }
+
+  | BuiltinRule {              -- Built-in rules are used for constant folding
+       ru_name :: RuleName,    -- and suchlike.  It has no free variables.
+       ru_fn :: Name,          -- Name of the Id at 
+                               -- the head of this rule
+       ru_try  :: [CoreExpr] -> Maybe CoreExpr }
+
+isBuiltinRule (BuiltinRule {}) = True
+isBuiltinRule _                       = False
 
 
-  | BuiltinRule                -- Built-in rules are used for constant folding
-       RuleName        -- and suchlike.  It has no free variables.
-       ([CoreExpr] -> Maybe CoreExpr)
+ruleName :: CoreRule -> RuleName
+ruleName = ru_name
 
 
-isBuiltinRule (BuiltinRule _ _) = True
-isBuiltinRule _                        = False
+ruleIdName :: CoreRule -> Name
+ruleIdName = ru_fn
 
 
-ruleName :: CoreRule -> RuleName
-ruleName (Rule n _ _ _)    = n
-ruleName (BuiltinRule n _) = n
+isLocalRule :: CoreRule -> Bool
+isLocalRule = ru_local
 \end{code}
 
 
 %************************************************************************
 %*                                                                     *
 \end{code}
 
 
 %************************************************************************
 %*                                                                     *
-\subsection{@Unfolding@ type}
+               Unfoldings
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 
@@ -214,7 +253,7 @@ data Unfolding
   | CoreUnfolding                      -- An unfolding with redundant cached information
                CoreExpr                -- Template; binder-info is correct
                Bool                    -- True <=> top level binding
   | 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
+               Bool                    -- exprIsHNF 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
                                        --      this variable
                Bool                    -- True <=> doesn't waste (much) work to expand inside an inlining
                                        --      Basically it's exprIsCheap
@@ -236,8 +275,10 @@ data UnfoldingGuidance
                                -- a context (case (thing args) of ...),
                                -- (where there are the right number of arguments.)
 
                                -- a context (case (thing args) of ...),
                                -- (where there are the right number of arguments.)
 
-noUnfolding = NoUnfolding
-mkOtherCon  = OtherCon
+noUnfolding    = NoUnfolding
+evaldUnfolding = OtherCon []
+
+mkOtherCon = OtherCon
 
 seqUnfolding :: Unfolding -> ()
 seqUnfolding (CoreUnfolding e top b1 b2 g)
 
 seqUnfolding :: Unfolding -> ()
 seqUnfolding (CoreUnfolding e top b1 b2 g)
@@ -318,6 +359,26 @@ instance Outputable AltCon where
 
 instance Show AltCon where
   showsPrec p con = showsPrecSDoc p (ppr con)
 
 instance Show AltCon where
   showsPrec p con = showsPrecSDoc p (ppr con)
+
+cmpAlt :: Alt b -> Alt b -> Ordering
+cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
+
+ltAlt :: Alt b -> Alt b -> Bool
+ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
+
+cmpAltCon :: AltCon -> AltCon -> Ordering
+-- Compares AltCons within a single list of alternatives
+cmpAltCon DEFAULT      DEFAULT    = EQ
+cmpAltCon DEFAULT      con        = LT
+
+cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
+cmpAltCon (DataAlt _)  DEFAULT      = GT
+cmpAltCon (LitAlt  l1) (LitAlt  l2) = l1 `compare` l2
+cmpAltCon (LitAlt _)   DEFAULT      = GT
+
+cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+> 
+                                 ppr con1 <+> ppr con2 )
+                     LT
 \end{code}
 
 
 \end{code}
 
 
@@ -340,12 +401,18 @@ type CoreAlt  = Alt  CoreBndr
 Binders are ``tagged'' with a \tr{t}:
 
 \begin{code}
 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}
 
 
 \end{code}
 
 
@@ -374,7 +441,7 @@ mkLets            :: [Bind b] -> Expr b -> Expr b
 mkLams       :: [b] -> Expr b -> Expr b
 
 mkLit lit        = Lit lit
 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
 
 mkLams binders body = foldr Lam body binders
 mkLets binds body   = foldr Let body binds
@@ -423,7 +490,6 @@ order.
 
 \begin{code}
 collectBinders              :: Expr b -> ([b],         Expr b)
 
 \begin{code}
 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)
 collectTyBinders                    :: CoreExpr -> ([TyVar],     CoreExpr)
 collectValBinders                   :: CoreExpr -> ([Id],        CoreExpr)
 collectTyAndValBinders              :: CoreExpr -> ([TyVar], [Id], CoreExpr)
@@ -434,16 +500,6 @@ collectBinders expr
     go bs (Lam b e) = go (b:bs) e
     go bs e         = (reverse bs, e)
 
     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)
   where
 collectTyAndValBinders expr
   = (tvs, ids, body)
   where
@@ -538,19 +594,21 @@ valArgCount (other  : args) = 1 + valArgCount args
 
 \begin{code}
 seqExpr :: CoreExpr -> ()
 
 \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
 
 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` ()
 seqNote other         = ()
 
 seqBndr b = b `seq` ()
@@ -567,12 +625,10 @@ 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
 
 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
+seqRules [] = ()
+seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) 
+  = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
+seqRules (BuiltinRule {} : rules) = seqRules rules
 \end{code}
 
 
 \end{code}
 
 
@@ -591,7 +647,8 @@ data AnnExpr' bndr annot
   | AnnLit     Literal
   | AnnLam     bndr (AnnExpr bndr annot)
   | AnnApp     (AnnExpr bndr annot) (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
   | AnnLet     (AnnBind bndr annot) (AnnExpr bndr annot)
   | AnnNote    Note (AnnExpr bndr annot)
   | AnnType    Type
@@ -620,10 +677,19 @@ deAnnotate' (AnnLet bind body)
     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 
     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)
 \end{code}
 
 
 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}
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)