TickBox representation change

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

diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 201d866..e580bed 100644 (file)
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -1,7 +1,9 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[CoreSyn]{A data type for the Haskell compiler midsection}
+
+CoreSyn: A data type for the Haskell compiler midsection
 
 \begin{code}
 module CoreSyn (
@@ -12,8 +14,8 @@ module CoreSyn (
        mkLets, mkLams, 
        mkApps, mkTyApps, mkValApps, mkVarApps,
        mkLit, mkIntLitInt, mkIntLit, 
-       mkConApp, 
-       varToCoreExpr,
+       mkConApp, mkCast,
+       varToCoreExpr, varsToCoreExprs,
 
        isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
        bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 
@@ -40,23 +42,27 @@ module CoreSyn (
 
        -- Core rules
        CoreRule(..),   -- CoreSubst, CoreTidy, CoreFVs, PprCore only
-       RuleName, seqRules, 
+       RuleName, seqRules, ruleArity,
        isBuiltinRule, ruleName, isLocalRule, ruleIdName
     ) where
 
 #include "HsVersions.h"
 
-import StaticFlags     ( opt_RuntimeTypes )
-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 DataCon         ( DataCon, dataConWorkId, dataConTag )
-import BasicTypes      ( Activation )
+import StaticFlags
+import CostCentre
+import Var
+import Type
+import Coercion
+import Name
+import OccName
+import Literal
+import DataCon
+import BasicTypes
 import FastString
 import Outputable
+
+infixl 4 `mkApps`, `mkValApps`, `mkTyApps`, `mkVarApps`
+-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
 \end{code}
 
 %************************************************************************
@@ -87,6 +93,7 @@ data Expr b   -- "b" for the type of binders,
        --              lit     (for LitAlts)
        --            This makes finding the relevant constructor easy,
        --            and makes comparison easier too
+  | Cast  (Expr b) Coercion
   | Note  Note (Expr b)
   | Type  Type                 -- This should only show up at the top
                                -- level of an Arg
@@ -107,7 +114,8 @@ type Arg b = Expr b         -- Can be a Type
 
 type Alt b = (AltCon, [b], Expr b)     -- (DEFAULT, [], rhs) is the default alternative
 
-data AltCon = DataAlt DataCon
+data AltCon = DataAlt DataCon  -- Invariant: the DataCon is always from 
+                               -- a *data* type, and never from a *newtype*
            | LitAlt  Literal
            | DEFAULT
         deriving (Eq, Ord)
@@ -119,13 +127,6 @@ data Bind b = NonRec b (Expr b)
 data Note
   = SCC CostCentre
 
-  | Coerce     
-       Type            -- The to-type:   type of whole coerce expression
-       Type            -- The from-type: type of enclosed expression
-
-  | InlineCall         -- Instructs simplifier to inline
-                       -- the enclosed call
-
   | InlineMe           -- Instructs simplifer to treat the enclosed expression
                        -- as very small, and inline it at its call sites
 
@@ -202,18 +203,23 @@ data CoreRule
        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 )
+       -- Orphan-hood; see Note [Orphans] in InstEnv
        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_nargs :: Int,        -- Number of args that ru_try expects
        ru_try  :: [CoreExpr] -> Maybe CoreExpr }
 
 isBuiltinRule (BuiltinRule {}) = True
 isBuiltinRule _                       = False
 
+ruleArity :: CoreRule -> Int
+ruleArity (BuiltinRule {ru_nargs = n}) = n
+ruleArity (Rule {ru_args = args})      = length args
+
 ruleName :: CoreRule -> RuleName
 ruleName = ru_name
 
@@ -452,6 +458,12 @@ mkIntLitInt n = Lit (mkMachInt (toInteger n))
 varToCoreExpr :: CoreBndr -> Expr b
 varToCoreExpr v | isId v    = Var v
                 | otherwise = Type (mkTyVarTy v)
+
+varsToCoreExprs :: [CoreBndr] -> [Expr b]
+varsToCoreExprs vs = map varToCoreExpr vs
+
+mkCast   :: Expr b -> Coercion -> Expr b
+mkCast e co = Cast e co
 \end{code}
 
 
@@ -599,15 +611,14 @@ 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 (Cast e co)     = seqExpr e `seq` seqType co
 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         = ()
 
@@ -647,9 +658,9 @@ data AnnExpr' bndr annot
   | AnnLit     Literal
   | AnnLam     bndr (AnnExpr bndr annot)
   | AnnApp     (AnnExpr bndr annot) (AnnExpr bndr annot)
--- gaw 2004
   | AnnCase    (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
   | AnnLet     (AnnBind bndr annot) (AnnExpr bndr annot)
+  | AnnCast     (AnnExpr bndr annot) Coercion
   | AnnNote    Note (AnnExpr bndr annot)
   | AnnType    Type
 
@@ -669,6 +680,7 @@ 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' (AnnCast e co)        = Cast (deAnnotate e) co
 deAnnotate' (AnnNote note body)   = Note note (deAnnotate body)
 
 deAnnotate' (AnnLet bind body)
@@ -677,7 +689,6 @@ deAnnotate' (AnnLet bind body)
     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 
--- gaw 2004
 deAnnotate' (AnnCase scrut v t alts)
   = Case (deAnnotate scrut) v t (map deAnnAlt alts)