X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=a074499fd325b28f26b9559df46fbe73bcc9fcb2;hb=1a03162e0239a336d297383107a68d06814e8924;hp=f7accde8eec39cd3f4037538ebc682f2dee2830c;hpb=8147a9f0bcc48ef0db1e91f8b985a4f5c3fed560;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index f7accde..a074499 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -1,478 +1,654 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[CoreSyn]{A data type for the Haskell compiler midsection}
 
 \begin{code}
-#include "HsVersions.h"
-
 module CoreSyn (
-	GenCoreBinding(..), GenCoreExpr(..), GenCoreAtom(..),
-	GenCoreCaseAlternatives(..), GenCoreCaseDefault(..),
-	pprCoreBinding, pprCoreExpr,
-
-	GenCoreArg(..), applyToArgs, decomposeArgs, collectArgs,
-
-	-- and to make the interface self-sufficient ...
+	Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
+	CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
+	TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
+
+	mkLets, mkLams, 
+	mkApps, mkTyApps, mkValApps, mkVarApps,
+	mkLit, mkIntLitInt, mkIntLit, 
+	mkConApp, 
+	varToCoreExpr,
+
+	isTyVar, isId, 
+	bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 
+	collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
+	collectArgs, 
+	coreExprCc,
+	flattenBinds, 
+
+	isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
+
+	-- Unfoldings
+	Unfolding(..),	UnfoldingGuidance(..), 	-- Both abstract everywhere but in CoreUnfold.lhs
+	noUnfolding, mkOtherCon,
+	unfoldingTemplate, maybeUnfoldingTemplate, otherCons, 
+	isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
+	hasUnfolding, hasSomeUnfolding, neverUnfold,
+
+	-- Seq stuff
+	seqRules, seqExpr, seqExprs, seqUnfolding,
+
+	-- Annotated expressions
+	AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, 
+	deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
+
+	-- Core rules
+	CoreRules(..), 	-- Representation needed by friends
+	CoreRule(..),	-- CoreSubst, CoreTidy, CoreFVs, PprCore only
+	IdCoreRule,
+	RuleName,
+	emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
+	isBuiltinRule, ruleName
     ) where
 
-import PrelInfo		( PrimOp, PrimRep
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-			)
-import Type		( isPrimType, pprParendUniType, TyVar, TyCon, Type
-			)
-import Literal		( Literal )
-import Id		( getIdUniType, isBottomingId, Id
-			  IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
-			)
+#include "HsVersions.h"
+
+import CmdLineOpts	( opt_RuntimeTypes )
+import CostCentre	( CostCentre, noCostCentre )
+import Var		( Var, Id, TyVar, isTyVar, isId )
+import Type		( Type, mkTyVarTy, seqType )
+import Literal	        ( Literal, mkMachInt )
+import DataCon		( DataCon, dataConWorkId )
+import BasicTypes	( Activation )
+import VarSet
+import FastString
 import Outputable
-import Pretty
-import CostCentre	( showCostCentre, CostCentre )
-import Util
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection[CoreTopBinding_and_CoreBinding]{@CoreTopBinding@ and @GenCoreBinding@}
+\subsection{The main data types}
 %*									*
 %************************************************************************
 
-Core programs, bindings, expressions, etc., are parameterised with
-respect to the information kept about binding and bound occurrences of
-variables, called {\em binders} and {\em val_occ tyvar uvars}, respectively.  [I
-don't really like the pair of names; I prefer {\em binder} and {\em
-bounder}.  Or {\em binder} and {\em var}.]
+These data types are the heart of the compiler
 
-A @GenCoreBinding@ is either a single non-recursive binding of a
-``binder'' to an expression, or a mutually-recursive blob of same.
 \begin{code}
-data GenCoreBinding val_bdr val_occ tyvar uvar
-  = NonRec	val_bdr (GenCoreExpr val_bdr val_occ tyvar uvar)
-  | Rec		[(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
+infixl 8 `App`	-- App brackets to the left
+
+data Expr b	-- "b" for the type of binders, 
+  = Var	  Id
+  | Lit   Literal
+  | 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,
+	--	      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
+
+data AltCon = DataAlt DataCon
+	    | LitAlt  Literal
+	    | DEFAULT
+	 deriving (Eq, Ord)
+
+data Bind b = NonRec b (Expr b)
+	      | Rec [(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
+
+  | 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
+-- look like valuse.  This is sometimes important:
+--	{-# INLINE f #-}
+--	f = g . h
+-- Here, f looks like a redex, and we aren't going to inline (.) because it's
+-- inside an INLINE, so it'll stay looking like a redex.  Nevertheless, we 
+-- should inline f even inside lambdas.  In effect, we should trust the programmer.
 \end{code}
 
+INVARIANTS:
+
+* The RHS of a letrec, and the RHSs of all top-level lets,
+  must be of LIFTED type.
+
+* The RHS of a let, may be of UNLIFTED type, but only if the expression 
+  is ok-for-speculation.  This means that the let can be floated around 
+  without difficulty.  e.g.
+	y::Int# = x +# 1#	ok
+	y::Int# = fac 4#	not ok [use case instead]
+
+* The argument of an App can be of any type.
+
+* The simplifier tries to ensure that if the RHS of a let is a constructor
+  application, its arguments are trivial, so that the constructor can be
+  inlined vigorously.
+
 
 %************************************************************************
 %*									*
-\subsection[GenCoreExpr]{Core expressions: @GenCoreExpr@}
+\subsection{Transformation rules}
 %*									*
 %************************************************************************
 
-@GenCoreExpr@ is the heart of the ``core'' data types; it is
-(more-or-less) boiled-down second-order polymorphic lambda calculus.
-For types in the core world, we just keep using @Types@.
+The CoreRule type and its friends are dealt with mainly in CoreRules,
+but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
+
 \begin{code}
-data GenCoreExpr val_bdr val_occ tyvar uvar
-     = Var    val_occ
-     | Lit    Literal	-- literal constants
-\end{code}
+data CoreRules 
+  = Rules [CoreRule]
+	  VarSet		-- Locally-defined free vars of RHSs
 
-@Cons@ and @Prims@ are saturated constructor and primitive-op
-applications (see the comment).  Note: @Con@s are only set up by the
-simplifier (and by the desugarer when it knows what it's doing).  The
-desugarer sets up constructors as applications of global @Vars@s.
+emptyCoreRules :: CoreRules
+emptyCoreRules = Rules [] emptyVarSet
 
-\begin{code}
-     | Con	Id (GenType tyvar) [GenCoreArg val_occ tyvar uvar]
-		-- Saturated constructor application:
-		-- The constructor is a function of the form:
-		--	/\ a1 -> ... /\ am -> \ b1 -> ... \ bn ->
-		-- <expr> where "/\" is a type lambda and "\" the
-		-- regular kind; there will be "m" Types and
-		-- "n" bindees in the Con args.
-		--
-		-- The type given is the result type of the application;
-		-- you can figure out the argument types from it if you want.
-
-     | Prim	PrimOp Type [GenCoreArg val_occ tyvar uvar]
-		-- saturated primitive operation;
-		-- comment on Cons applies here, too.
-		-- The types work the same way
-		-- (PrimitiveOps may be polymorphic).
-\end{code}
+isEmptyCoreRules :: CoreRules -> Bool
+isEmptyCoreRules (Rules rs _) = null rs
 
-Ye olde abstraction and application operators.
-\begin{code}
-     | Lam	(GenCoreBinder val_bdr tyvar uvar)
-		(GenCoreExpr val_bdr val_occ tyvar uvar)
+rulesRhsFreeVars :: CoreRules -> VarSet
+rulesRhsFreeVars (Rules _ fvs) = fvs
 
-     | App	(GenCoreExpr val_bdr val_occ tyvar uvar)
-		(GenCoreArg val_occ tyvar uvar)
+rulesRules :: CoreRules -> [CoreRule]
+rulesRules (Rules rules _) = rules
 \end{code}
 
-Case expressions (\tr{case <expr> of <List of alternatives>}): there
-are really two flavours masquerading here---those for scrutinising
-{\em algebraic} types and those for {\em primitive} types.  Please see
-under @GenCoreCaseAlternatives@.
 \begin{code}
-     | Case	(GenCoreExpr val_bdr val_occ tyvar uvar)
-		(GenCoreCaseAlternatives val_bdr val_occ tyvar uvar)
+type RuleName = FastString
+type IdCoreRule = (Id,CoreRule)		-- Rules don't have their leading Id inside them
+
+data CoreRule
+  = Rule RuleName
+	 Activation	-- When the rule is active
+	 [CoreBndr]	-- Forall'd variables
+	 [CoreExpr]	-- LHS args
+	 CoreExpr	-- RHS
+
+  | BuiltinRule		-- Built-in rules are used for constant folding
+	RuleName	-- and suchlike.  It has no free variables.
+	([CoreExpr] -> Maybe CoreExpr)
+
+isBuiltinRule (BuiltinRule _ _) = True
+isBuiltinRule _		        = False
+
+ruleName :: CoreRule -> RuleName
+ruleName (Rule n _ _ _ _)  = n
+ruleName (BuiltinRule n _) = n
 \end{code}
 
-A Core case expression \tr{case e of v -> ...} implies evaluation of
-\tr{e}; it is not equivalent to \tr{let v = in ...} (as with a Haskell
-\tr{case}).
 
-Non-recursive @Lets@ only have one binding; having more than one
-doesn't buy you much, and it is an easy way to mess up variable
-scoping.
+%************************************************************************
+%*									*
+\subsection{@Unfolding@ type}
+%*									*
+%************************************************************************
+
+The @Unfolding@ type is declared here to avoid numerous loops, but it
+should be abstract everywhere except in CoreUnfold.lhs
+
 \begin{code}
-     | Let	(GenCoreBinding val_bdr val_occ tyvar uvar)
-		(GenCoreExpr binder val_occ tyvar uvar)
-		-- both recursive and non-.
-		-- The "GenCoreBinding" records that information
+data Unfolding
+  = NoUnfolding
+
+  | OtherCon [AltCon]		-- It ain't one of these
+				-- (OtherCon xs) also indicates that something has been evaluated
+				-- and hence there's no point in re-evaluating it.
+				-- OtherCon [] is used even for non-data-type values
+				-- to indicated evaluated-ness.  Notably:
+				--	data C = C !(Int -> Int)
+				-- 	case x of { C f -> ... }
+				-- Here, f gets an OtherCon [] unfolding.
+
+  | CompulsoryUnfolding CoreExpr	-- There is no "original" definition,
+					-- so you'd better unfold.
+
+  | 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
+					--	this variable
+		Bool			-- True <=> doesn't waste (much) work to expand inside an inlining
+					-- 	Basically it's exprIsCheap
+		UnfoldingGuidance	-- Tells about the *size* of the template.
+
+
+data UnfoldingGuidance
+  = UnfoldNever
+  | UnfoldIfGoodArgs	Int	-- and "n" value args
+
+			[Int]	-- Discount if the argument is evaluated.
+				-- (i.e., a simplification will definitely
+				-- be possible).  One elt of the list per *value* arg.
+
+			Int	-- The "size" of the unfolding; to be elaborated
+				-- later. ToDo
+
+			Int	-- Scrutinee discount: the discount to substract if the thing is in
+				-- a context (case (thing args) of ...),
+				-- (where there are the right number of arguments.)
+
+noUnfolding = NoUnfolding
+mkOtherCon  = OtherCon
+
+seqUnfolding :: Unfolding -> ()
+seqUnfolding (CoreUnfolding e top b1 b2 g)
+  = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
+seqUnfolding other = ()
+
+seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
+seqGuidance other			= ()
 \end{code}
 
-For cost centre scc expressions we introduce a new core construct
-@SCC@ so transforming passes have to deal with it explicitly. The
-alternative of using a new PrimativeOp may result in a bad
-transformations of which we are unaware.
 \begin{code}
-     | SCC	CostCentre				    -- label of scc
-		(GenCoreExpr val_bdr val_occ tyvar uvar)    -- scc expression
+unfoldingTemplate :: Unfolding -> CoreExpr
+unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
+unfoldingTemplate (CompulsoryUnfolding expr)   = expr
+unfoldingTemplate other = panic "getUnfoldingTemplate"
+
+maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
+maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
+maybeUnfoldingTemplate (CompulsoryUnfolding expr)   = Just expr
+maybeUnfoldingTemplate other 			    = Nothing
+
+otherCons :: Unfolding -> [AltCon]
+otherCons (OtherCon cons) = cons
+otherCons other		  = []
+
+isValueUnfolding :: Unfolding -> Bool
+	-- Returns False for OtherCon
+isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
+isValueUnfolding other			          = False
+
+isEvaldUnfolding :: Unfolding -> Bool
+	-- Returns True for OtherCon
+isEvaldUnfolding (OtherCon _)		          = True
+isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
+isEvaldUnfolding other			          = False
+
+isCheapUnfolding :: Unfolding -> Bool
+isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
+isCheapUnfolding other			  	  = False
+
+isCompulsoryUnfolding :: Unfolding -> Bool
+isCompulsoryUnfolding (CompulsoryUnfolding _) = True
+isCompulsoryUnfolding other		      = False
+
+hasUnfolding :: Unfolding -> Bool
+hasUnfolding (CoreUnfolding _ _ _ _ _) = True
+hasUnfolding (CompulsoryUnfolding _)   = True
+hasUnfolding other 	 	       = False
+
+hasSomeUnfolding :: Unfolding -> Bool
+hasSomeUnfolding NoUnfolding = False
+hasSomeUnfolding other	     = True
+
+neverUnfold :: Unfolding -> Bool
+neverUnfold NoUnfolding				= True
+neverUnfold (OtherCon _)			= True
+neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
+neverUnfold other 				= False
 \end{code}
 
 
 %************************************************************************
 %*									*
-\subsection{Case alternatives in @GenCoreExpr@}
+\subsection{The main data type}
 %*									*
 %************************************************************************
 
-We have different kinds of @case@s, the differences being reflected in
-the kinds of alternatives a case has.  We maintain a distinction
-between cases for scrutinising algebraic datatypes, as opposed to
-primitive types.  In both cases, we carry around a @TyCon@, as a
-handle with which we can get info about the case (e.g., total number
-of data constructors for this type).
-
-For example:
-\begin{verbatim}
-let# x=e in b
-\end{verbatim}
-becomes
-\begin{verbatim}
-Case e [ BindDefaultAlt x -> b ]
-\end{verbatim}
-
 \begin{code}
-data GenCoreCaseAlternatives val_bdr val_occ tyvar uvar
-
-  = AlgAlts	[(Id,				-- alts: data constructor,
-		  [val_bdr],			-- constructor's parameters,
-		  GenCoreExpr val_bdr val_occ tyvar uvar)]	-- rhs.
-		(GenCoreCaseDefault val_bdr val_occ tyvar uvar)
-
-  | PrimAlts	[(Literal,			-- alts: unboxed literal,
-		  GenCoreExpr val_bdr val_occ tyvar uvar)]	-- rhs.
-		(GenCoreCaseDefault val_bdr val_occ tyvar uvar)
-
--- obvious things: if there are no alts in the list, then the default
--- can't be NoDefault.
-
-data GenCoreCaseDefault val_bdr val_occ tyvar uvar
-  = NoDefault					-- small con family: all
-						-- constructor accounted for
-  | BindDefault val_bdr				-- form: var -> expr;
-		(GenCoreExpr val_bdr val_occ tyvar uvar)	-- "val_bdr" may or may not
-						-- be used in RHS.
+-- The Ord is needed for the FiniteMap used in the lookForConstructor
+-- in SimplEnv.  If you declared that lookForConstructor *ignores*
+-- constructor-applications with LitArg args, then you could get
+-- rid of this Ord.
+
+instance Outputable AltCon where
+  ppr (DataAlt dc) = ppr dc
+  ppr (LitAlt lit) = ppr lit
+  ppr DEFAULT      = ptext SLIT("__DEFAULT")
+
+instance Show AltCon where
+  showsPrec p con = showsPrecSDoc p (ppr con)
 \end{code}
 
+
 %************************************************************************
 %*									*
-\subsection[CoreSyn-arguments]{Core ``argument'' wrapper type}
+\subsection{Useful synonyms}
 %*									*
 %************************************************************************
 
+The common case
+
+\begin{code}
+type CoreBndr = Var
+type CoreExpr = Expr CoreBndr
+type CoreArg  = Arg  CoreBndr
+type CoreBind = Bind CoreBndr
+type CoreAlt  = Alt  CoreBndr
+\end{code}
+
+Binders are ``tagged'' with a \tr{t}:
+
 \begin{code}
-data GenCoreAtom val_occ tyvar uvar
-  = LitAtom	Literal
-  | VarAtom	val_occ
-  | TyAtom	(GenType tyvar)
-  | UsageAtom	(Usage uvar)
+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)
 
-===+*** fix from here down ****===
-=================================
+instance Outputable b => Outputable (TaggedBndr b) where
+  ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
 
-instance Outputable bindee => Outputable (GenCoreArg bindee) where
-  ppr sty (ValArg atom) = ppr sty atom
-  ppr sty (TypeArg ty)  = ppr sty ty
+instance Outputable b => OutputableBndr (TaggedBndr b) where
+  pprBndr _ b = ppr b	-- Simple
 \end{code}
 
+
+%************************************************************************
+%*									*
+\subsection{Core-constructing functions with checking}
+%*									*
+%************************************************************************
+
 \begin{code}
-applyToArgs :: GenCoreExpr val_bdr bindee
-	    -> [GenCoreArg bindee]
-	    -> GenCoreExpr val_bdr bindee
+mkApps    :: Expr b -> [Arg b]  -> Expr b
+mkTyApps  :: Expr b -> [Type]   -> Expr b
+mkValApps :: Expr b -> [Expr b] -> Expr b
+mkVarApps :: Expr b -> [Var] -> Expr b
+
+mkApps    f args = foldl App		  	   f args
+mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
+mkValApps f args = foldl (\ e a -> App e a)	   f args
+mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
+
+mkLit         :: Literal -> Expr b
+mkIntLit      :: Integer -> Expr b
+mkIntLitInt   :: Int     -> Expr b
+mkConApp      :: DataCon -> [Arg b] -> Expr b
+mkLets	      :: [Bind b] -> Expr b -> Expr b
+mkLams	      :: [b] -> Expr b -> Expr b
+
+mkLit lit	  = Lit lit
+mkConApp con args = mkApps (Var (dataConWorkId con)) args
+
+mkLams binders body = foldr Lam body binders
+mkLets binds body   = foldr Let body binds
+
+mkIntLit    n = Lit (mkMachInt n)
+mkIntLitInt n = Lit (mkMachInt (toInteger n))
+
+varToCoreExpr :: CoreBndr -> Expr b
+varToCoreExpr v | isId v    = Var v
+                | otherwise = Type (mkTyVarTy v)
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Simple access functions}
+%*									*
+%************************************************************************
+
+\begin{code}
+bindersOf  :: Bind b -> [b]
+bindersOf (NonRec binder _) = [binder]
+bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
+
+bindersOfBinds :: [Bind b] -> [b]
+bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
+
+rhssOfBind :: Bind b -> [Expr b]
+rhssOfBind (NonRec _ rhs) = [rhs]
+rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
+
+rhssOfAlts :: [Alt b] -> [Expr b]
+rhssOfAlts alts = [e | (_,_,e) <- alts]
 
-applyToArgs fun []		    = fun
-applyToArgs fun (ValArg val : args) = applyToArgs (App  fun val) args
-applyToArgs fun (TypeArg ty : args) = applyToArgs (CoTyApp fun ty) args
+flattenBinds :: [Bind b] -> [(b, Expr b)]	-- Get all the lhs/rhs pairs
+flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
+flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
+flattenBinds []			  = []
 \end{code}
 
-@decomposeArgs@ just pulls of the contiguous TypeArg-then-ValArg block
-on the front of the args.  Pretty common.
+We often want to strip off leading lambdas before getting down to
+business.  @collectBinders@ is your friend.
+
+We expect (by convention) type-, and value- lambdas in that
+order.
 
 \begin{code}
-decomposeArgs :: [GenCoreArg bindee]
-	      -> ([Type], [GenCoreAtom bindee], [GenCoreArg bindee])
+collectBinders	             :: Expr b -> ([b],         Expr b)
+collectTyBinders       	     :: CoreExpr -> ([TyVar],     CoreExpr)
+collectValBinders      	     :: CoreExpr -> ([Id],        CoreExpr)
+collectTyAndValBinders 	     :: CoreExpr -> ([TyVar], [Id], CoreExpr)
 
-decomposeArgs [] = ([],[],[])
+collectBinders expr
+  = go [] expr
+  where
+    go bs (Lam b e) = go (b:bs) e
+    go bs e	     = (reverse bs, e)
 
-decomposeArgs (TypeArg ty : args)
-  = case (decomposeArgs args) of { (tys, vals, rest) ->
-    (ty:tys, vals, rest) }
+collectTyAndValBinders expr
+  = (tvs, ids, body)
+  where
+    (tvs, body1) = collectTyBinders expr
+    (ids, body)  = collectValBinders body1
 
-decomposeArgs (ValArg val : args)
-  = case (do_vals args) of { (vals, rest) ->
-    ([], val:vals, rest) }
+collectTyBinders expr
+  = go [] expr
   where
-    do_vals (ValArg val : args)
-      = case (do_vals args) of { (vals, rest) ->
-    	(val:vals, rest) }
+    go tvs (Lam b e) | isTyVar b = go (b:tvs) e
+    go tvs e			 = (reverse tvs, e)
 
-    do_vals args = ([], args)
+collectValBinders expr
+  = go [] expr
+  where
+    go ids (Lam b e) | isId b = go (b:ids) e
+    go ids body		      = (reverse ids, body)
 \end{code}
 
+
 @collectArgs@ takes an application expression, returning the function
 and the arguments to which it is applied.
 
 \begin{code}
-collectArgs :: GenCoreExpr val_bdr bindee
-	    -> (GenCoreExpr val_bdr bindee, [GenCoreArg bindee])
-
+collectArgs :: Expr b -> (Expr b, [Arg b])
 collectArgs expr
-  = collect expr []
+  = go expr []
   where
-    collect (App fun arg)  args = collect fun (ValArg arg : args)
-    collect (CoTyApp fun ty) args = collect fun (TypeArg ty : args)
-    collect other_expr args 	  = (other_expr, args)
+    go (App f a) as = go f (a:as)
+    go e 	 as = (e, as)
 \end{code}
 
+coreExprCc gets the cost centre enclosing an expression, if any.
+It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
+
+\begin{code}
+coreExprCc :: Expr b -> CostCentre
+coreExprCc (Note (SCC cc) e)   = cc
+coreExprCc (Note other_note e) = coreExprCc e
+coreExprCc (Lam _ e)           = coreExprCc e
+coreExprCc other               = noCostCentre
+\end{code}
+
+
+
 %************************************************************************
 %*									*
-\subsection[CoreSyn-output]{Instance declarations for output}
+\subsection{Predicates}
 %*									*
 %************************************************************************
 
-@pprCoreBinding@ and @pprCoreExpr@ let you give special printing
-function for ``major'' val_bdrs (those next to equal signs :-),
-``minor'' ones (lambda-bound, case-bound), and bindees.  They would
-usually be called through some intermediary.
+@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
+i.e. if type applications are actual lambdas because types are kept around
+at runtime.  
+
+Similarly isRuntimeArg.  
 
 \begin{code}
-pprCoreBinding
-	:: PprStyle
-	-> (PprStyle -> bndr -> Pretty)	-- to print "major" val_bdrs
-	-> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
-	-> (PprStyle -> bdee -> Pretty) -- to print bindees
-	-> GenCoreBinding bndr bdee
-	-> Pretty
-
-pprCoreBinding sty pbdr1 pbdr2 pbdee (NonRec val_bdr expr)
-  = ppHang (ppCat [pbdr1 sty val_bdr, ppEquals])
-	 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-
-pprCoreBinding sty pbdr1 pbdr2 pbdee (Rec binds)
-  = ppAboves [ifPprDebug sty (ppStr "{- Rec -}"),
-	      ppAboves (map ppr_bind binds),
-	      ifPprDebug sty (ppStr "{- end Rec -}")]
-  where
-    ppr_bind (val_bdr, expr)
-      = ppHang (ppCat [pbdr1 sty val_bdr, ppEquals])
-	     4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
+isRuntimeVar :: Var -> Bool
+isRuntimeVar | opt_RuntimeTypes = \v -> True
+	     | otherwise	= \v -> isId v
+
+isRuntimeArg :: CoreExpr -> Bool
+isRuntimeArg | opt_RuntimeTypes = \e -> True
+	     | otherwise	= \e -> isValArg e
 \end{code}
 
 \begin{code}
-instance (Outputable bndr, Outputable bdee)
-		=> Outputable (GenCoreBinding bndr bdee) where
-    ppr sty bind = pprCoreBinding sty ppr ppr ppr bind
+isValArg (Type _) = False
+isValArg other    = True
 
-instance (Outputable bndr, Outputable bdee)
-		=> Outputable (GenCoreExpr bndr bdee) where
-    ppr sty expr = pprCoreExpr sty ppr ppr ppr expr
+isTypeArg (Type _) = True
+isTypeArg other    = False
 
-instance Outputable bdee => Outputable (GenCoreAtom bdee) where
-    ppr sty atom = pprCoreAtom sty ppr atom
-\end{code}
+valBndrCount :: [CoreBndr] -> Int
+valBndrCount []		    	  = 0
+valBndrCount (b : bs) | isId b    = 1 + valBndrCount bs
+		      | otherwise = valBndrCount bs
 
-\begin{code}
-pprCoreAtom
-	:: PprStyle
-	-> (PprStyle -> bdee -> Pretty) -- to print bindees
-	-> GenCoreAtom bdee
-	-> Pretty
-
-pprCoreAtom sty pbdee (LitAtom lit) = ppr sty lit
-pprCoreAtom sty pbdee (VarAtom v)   = pbdee sty v
+valArgCount :: [Arg b] -> Int
+valArgCount []		    = 0
+valArgCount (Type _ : args) = valArgCount args
+valArgCount (other  : args) = 1 + valArgCount args
 \end{code}
 
-\begin{code}
-pprCoreExpr, pprParendCoreExpr
-	:: PprStyle
-	-> (PprStyle -> bndr -> Pretty)	-- to print "major" val_bdrs
-	-> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
-	-> (PprStyle -> bdee -> Pretty) -- to print bindees
-	-> GenCoreExpr bndr bdee
-	-> Pretty
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Var name) = pbdee sty name
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Lit literal) = ppr sty literal
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Con con [] []) = ppr sty con
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Con con types args)
-  = ppHang (ppBesides [ppr sty con, ppChar '!'])
-	 4 (ppSep (  (map (pprParendUniType sty) types)
-		  ++ (map (pprCoreAtom sty pbdee) args)))
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Prim prim tys args)
-  = ppHang (ppBesides [ppr sty prim, ppChar '!'])
-	 4 (ppSep (  (map (pprParendUniType sty) tys)
-		  ++ (map (pprCoreAtom sty pbdee) args) ))
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Lam val_bdr expr)
-  = ppHang (ppCat [ppStr "\\", pbdr2 sty val_bdr, ppStr "->"])
-	 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyLam tyvar expr)
-  = ppHang (ppCat [ppStr "/\\", interppSP sty (tyvar:tyvars),
-		   ppStr "->", pp_varss var_lists])
-	   4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr_after)
-  where
-    (tyvars, var_lists, expr_after) = collect_tyvars expr
-
-    collect_tyvars (CoTyLam tyv e) = ( tyv:tyvs, vs, e_after )
-      where (tyvs, vs, e_after) = collect_tyvars e
-    collect_tyvars e@(Lam _ _)   = ( [], vss, e_after )
-      where (vss, e_after) = collect_vars e
-    collect_tyvars other_e	   = ( [], [], other_e )
-
-    collect_vars (Lam var e) = ([var]:varss, e_after)
-      where (varss, e_after) = collect_vars e
-    collect_vars other_e	   = ( [], other_e )
-
-    pp_varss [] = ppNil
-    pp_varss (vars:varss)
-      = ppCat [ppStr "\\", ppInterleave ppSP (map (pbdr2 sty) vars),
-	       ppStr "->", pp_varss varss]
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee expr@(App fun_expr atom)
-  = let
-	(fun, args) = collect_args expr []
-    in
-    ppHang (pprParendCoreExpr sty pbdr1 pbdr2 pbdee fun)
-	 4 (ppSep (map (pprCoreAtom sty pbdee) args))
-  where
-    collect_args (App fun arg) args = collect_args fun (arg:args)
-    collect_args fun		 args = (fun, args)
 
-pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyApp expr ty)
-  = ppHang (ppBeside pp_note (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr))
-	 4 (pprParendUniType sty ty)
-  where
-    pp_note = ifPprShowAll sty (ppStr "{-CoTyApp-} ")
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Case expr alts)
-  = ppSep [ppSep [ppStr "case", ppNest 4 (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr),
-		     ppStr "of {"],
-	   ppNest 2 (pprCoreCaseAlts sty pbdr1 pbdr2 pbdee alts),
-	   ppStr "}"]
-
--- special cases: let ... in let ...
--- ("disgusting" SLPJ)
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
-  = ppAboves [
-      ppCat [ppStr "let {", pbdr1 sty val_bdr, ppEquals],
-      ppNest 2 (pprCoreExpr sty pbdr1 pbdr2 pbdee rhs),
-      ppStr "} in",
-      pprCoreExpr sty pbdr1 pbdr2 pbdee body ]
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
-  = ppAbove
-      (ppHang (ppStr "let {")
-	    2 (ppCat [ppHang (ppCat [pbdr1 sty val_bdr, ppEquals])
-			   4 (pprCoreExpr sty pbdr1 pbdr2 pbdee rhs),
-       ppStr "} in"]))
-      (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-
--- general case (recursive case, too)
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind expr)
-  = ppSep [ppHang (ppStr "let {") 2 (pprCoreBinding sty pbdr1 pbdr2 pbdee bind),
-	   ppHang (ppStr "} in ") 2 (pprCoreExpr    sty pbdr1 pbdr2 pbdee expr)]
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (SCC cc expr)
-  = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)],
-	    pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr ]
-\end{code}
+%************************************************************************
+%*									*
+\subsection{Seq stuff}
+%*									*
+%************************************************************************
 
 \begin{code}
-pprParendCoreExpr sty pbdr1 pbdr2 pbdee e@(Var _) = pprCoreExpr sty pbdr1 pbdr2 pbdee e
-pprParendCoreExpr sty pbdr1 pbdr2 pbdee e@(Lit _) = pprCoreExpr sty pbdr1 pbdr2 pbdee e
-pprParendCoreExpr sty pbdr1 pbdr2 pbdee other_e
-  = ppBesides [ppLparen, pprCoreExpr sty pbdr1 pbdr2 pbdee other_e, ppRparen]
+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
+
+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` ()
+
+seqBndrs [] = ()
+seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
+
+seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
+seqBind (Rec prs)    = seqPairs prs
+
+seqPairs [] = ()
+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
+
+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
 \end{code}
 
+
+
+%************************************************************************
+%*									*
+\subsection{Annotated core; annotation at every node in the tree}
+%*									*
+%************************************************************************
+
 \begin{code}
-instance (Outputable bndr, Outputable bdee)
-		=> Outputable (GenCoreCaseAlternatives bndr bdee) where
-    ppr sty alts = pprCoreCaseAlts sty ppr ppr ppr alts
+type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
+
+data AnnExpr' bndr annot
+  = AnnVar	Id
+  | AnnLit	Literal
+  | AnnLam	bndr (AnnExpr bndr annot)
+  | AnnApp	(AnnExpr bndr annot) (AnnExpr bndr annot)
+  | AnnCase	(AnnExpr bndr annot) bndr [AnnAlt bndr annot]
+  | AnnLet	(AnnBind bndr annot) (AnnExpr bndr annot)
+  | AnnNote	Note (AnnExpr bndr annot)
+  | AnnType	Type
+
+type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
+
+data AnnBind bndr annot
+  = AnnNonRec bndr (AnnExpr bndr annot)
+  | AnnRec    [(bndr, AnnExpr bndr annot)]
 \end{code}
 
 \begin{code}
-pprCoreCaseAlts
-	:: PprStyle
-	-> (PprStyle -> bndr -> Pretty)	-- to print "major" val_bdrs
-	-> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
-	-> (PprStyle -> bdee -> Pretty) -- to print bindees
-	-> GenCoreCaseAlternatives bndr bdee
-	-> Pretty
-
-pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (AlgAlts alts deflt)
-  = ppAboves [ ppAboves (map ppr_alt alts),
-	       pprCoreCaseDefault sty pbdr1 pbdr2 pbdee deflt ]
+deAnnotate :: AnnExpr bndr annot -> Expr bndr
+deAnnotate (_, e) = deAnnotate' e
+
+deAnnotate' (AnnType t)           = Type t
+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' (AnnNote note body)   = Note note (deAnnotate body)
+
+deAnnotate' (AnnLet bind body)
+  = Let (deAnnBind bind) (deAnnotate body)
   where
-    ppr_alt (con, params, expr)
-      = ppHang (ppCat [ppr_con con,
-		       ppInterleave ppSP (map (pbdr2 sty) params),
-		       ppStr "->"])
-		4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-      where
-    	ppr_con con
-    	  = if isOpLexeme con
-	    then ppBesides [ppLparen, ppr sty con, ppRparen]
-	    else ppr sty con
-
-pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (PrimAlts alts deflt)
-  = ppAboves [ ppAboves (map ppr_alt alts),
-	       pprCoreCaseDefault sty pbdr1 pbdr2 pbdee deflt ]
-  where
-    ppr_alt (lit, expr)
-      = ppHang (ppCat [ppr sty lit, ppStr "->"])
-	     4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-\end{code}
+    deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
+    deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 
-\begin{code}
-instance (Outputable bndr, Outputable bdee)
-		=> Outputable (GenCoreCaseDefault bndr bdee) where
-    ppr sty deflt  = pprCoreCaseDefault sty ppr ppr ppr deflt
+deAnnotate' (AnnCase scrut v alts)
+  = Case (deAnnotate scrut) v (map deAnnAlt alts)
+
+deAnnAlt :: AnnAlt bndr annot -> Alt bndr
+deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 \end{code}
 
 \begin{code}
-pprCoreCaseDefault
-	:: PprStyle
-	-> (PprStyle -> bndr -> Pretty)	-- to print "major" val_bdrs
-	-> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
-	-> (PprStyle -> bdee -> Pretty) -- to print bindees
-	-> GenCoreCaseDefault bndr bdee
-	-> Pretty
-
-pprCoreCaseDefault sty pbdr1 pbdr2 pbdee NoDefault = ppNil
-
-pprCoreCaseDefault sty pbdr1 pbdr2 pbdee (BindDefault val_bdr expr)
-  = ppHang (ppCat [pbdr2 sty val_bdr, ppStr "->"])
-	 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
+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}