X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreSyn.lhs;h=65a1b406aaa714a88cb2f322b033ef574e8ccd10;hb=a84a227cee9e87b4fa872366a4ac3ae0eeda16ef;hp=331a890760df20d04c31a4754d47fe67ec6a0c64;hpb=f2dcf256399e9a2de6343c625630b51f8abf4863;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 331a890..65a1b40 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -12,8 +12,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, 
@@ -50,6 +50,7 @@ import StaticFlags	( opt_RuntimeTypes )
 import CostCentre	( CostCentre, noCostCentre )
 import Var		( Var, Id, TyVar, isTyVar, isId )
 import Type		( Type, mkTyVarTy, seqType )
+import Coercion         ( Coercion )
 import Name		( Name )
 import OccName		( OccName )
 import Literal	        ( Literal, mkMachInt )
@@ -57,6 +58,9 @@ import DataCon		( DataCon, dataConWorkId, dataConTag )
 import BasicTypes	( Activation )
 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 +91,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 +112,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,10 +125,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
-
   | InlineMe		-- Instructs simplifer to treat the enclosed expression
 			-- as very small, and inline it at its call sites
 
@@ -449,6 +451,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}
 
 
@@ -596,15 +604,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	       = ()
 
@@ -644,9 +651,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
 
@@ -666,6 +673,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)
@@ -674,7 +682,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)