remove empty dir

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

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 4c70bb3..201d866 100644 (file)
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -15,7 +15,7 @@ module CoreSyn (
        mkConApp, 
        varToCoreExpr,
 
        mkConApp, 
        varToCoreExpr,
 

-       isTyVar, isId, 
+       isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,

        bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 
        collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
        collectArgs, 
        bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 
        collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
        collectArgs, 

@@ -26,37 +26,35 @@ 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, 
        deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
 
        -- Core rules
 
        -- Annotated expressions
        AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, 
        deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
 
        -- 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, dataConWorkId )
+import DataCon         ( DataCon, dataConWorkId, dataConTag )

 import BasicTypes      ( Activation )
 import BasicTypes      ( Activation )

-import VarSet

 import FastString
 import Outputable
 \end{code}
 import FastString
 import Outputable
 \end{code}

@@ -78,13 +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
-       -- Invariant: the list of alternatives is ALWAYS EXHAUSTIVE
-       -- Invariant: the 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

@@ -94,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))]
 

@@ -150,51 +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
-
-isEmptyCoreRules :: CoreRules -> Bool
-isEmptyCoreRules (Rules rs _) = null rs
+A Rule is 

 
 

-rulesRhsFreeVars :: CoreRules -> VarSet
-rulesRhsFreeVars (Rules _ fvs) = fvs
+  "local"  if the function it is a rule for is defined in the
+          same module as the rule itself.

 
 

-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}
 type RuleName = FastString
 
 \begin{code}
 type RuleName = FastString

-type IdCoreRule = (Id,CoreRule)                -- Rules don't have their leading Id inside them

 
 data CoreRule
 
 data CoreRule

-  = Rule RuleName
-        Activation     -- When the rule is active
-        [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

 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

@@ -220,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

@@ -242,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)

@@ -324,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}
 
 

@@ -539,14 +594,15 @@ 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
 
 seqExprs [] = ()
 seqExprs (e:es) = seqExpr e `seq` seqExprs es

@@ -569,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}
 
 

@@ -593,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

@@ -622,8 +677,9 @@ 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)
 
 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)