X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=60a7db0cc057364ec348ac8ea4829e23243e8cdc;hb=cae34044d89a87bd3da83b0e867b4a5d6994079a;hp=80937db165f4581cb2dff375ed3f3a9d1443235e;hpb=5ca77490a603e0175bb717343884533ad8de017d;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 80937db..60a7db0 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -5,16 +5,17 @@
 
 \begin{code}
 module CoreSyn (
-	Expr(..), Alt, Bind(..), Arg(..), Note(..),
+	Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
 	CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
 	TaggedExpr, TaggedAlt, TaggedBind, TaggedArg,
 
-	mkLets, mkLams,
+	mkLets, mkLams, 
 	mkApps, mkTyApps, mkValApps, mkVarApps,
-	mkLit, mkStringLit, mkStringLitFS, mkConApp, mkPrimApp, mkNote,
-	bindNonRec, mkIfThenElse, varToCoreExpr,
+	mkLit, mkIntLitInt, mkIntLit, 
+	mkConApp, 
+	varToCoreExpr,
 
-	bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isDeadBinder, isTyVar, isId,
+	bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isTyVar, isId,
 	collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
 	collectArgs, collectBindersIgnoringNotes,
 	coreExprCc,
@@ -22,34 +23,34 @@ module CoreSyn (
 
 	isValArg, isTypeArg, valArgCount, valBndrCount,
 
-	-- Seq stuff
-	seqRules, seqExpr, seqExprs, 
+	-- Unfoldings
+	Unfolding(..),	UnfoldingGuidance(..), 	-- Both abstract everywhere but in CoreUnfold.lhs
+	noUnfolding, mkOtherCon,
+	unfoldingTemplate, maybeUnfoldingTemplate, otherCons, 
+	isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
+	hasUnfolding, hasSomeUnfolding,
 
-	-- Size
-	coreBindsSize,
+	-- Seq stuff
+	seqRules, seqExpr, seqExprs, seqUnfolding,
 
 	-- Annotated expressions
-	AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate,
+	AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate, deAnnotate',
 
 	-- Core rules
 	CoreRules(..), 	-- Representation needed by friends
 	CoreRule(..),	-- CoreSubst, CoreTidy, CoreFVs, PprCore only
 	RuleName,
-	emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules
+	emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
+	isBuiltinRule
     ) where
 
 #include "HsVersions.h"
 
-import TysWiredIn	( boolTy, stringTy, nilDataCon )
-import CostCentre	( CostCentre, isDupdCC, noCostCentre )
-import Var		( Var, Id, TyVar, IdOrTyVar, isTyVar, isId, idType )
-import VarEnv
-import Id		( mkWildId, getIdOccInfo, idInfo )
+import CostCentre	( CostCentre, noCostCentre )
+import Var		( Var, Id, TyVar, isTyVar, isId, idType )
 import Type		( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType )
-import IdInfo		( OccInfo(..), megaSeqIdInfo )
-import Const	        ( Con(..), DataCon, Literal(MachStr), mkMachInt, PrimOp )
-import TysWiredIn	( trueDataCon, falseDataCon )
-import ThinAir		( unpackCStringId, unpackCString2Id, addr2IntegerId )
+import Literal	        ( Literal(MachStr), mkMachInt )
+import DataCon		( DataCon, dataConId )
 import VarSet
 import Outputable
 \end{code}
@@ -67,9 +68,7 @@ infixl 8 `App`	-- App brackets to the left
 
 data Expr b	-- "b" for the type of binders, 
   = Var	  Id
-  | Con   Con [Arg b]		-- Guaranteed saturated
-				-- The Con can be a DataCon, Literal, PrimOP
-				-- but cannot be DEFAULT
+  | Lit   Literal
   | App   (Expr b) (Arg b)
   | Lam   b (Expr b)
   | Let   (Bind b) (Expr b)
@@ -81,9 +80,12 @@ data Expr b	-- "b" for the type of binders,
 
 type Arg b = Expr b		-- Can be a Type
 
-type Alt b = (Con, [b], Expr b)
-	-- (DEFAULT, [], rhs) is the default alternative
-	-- The Con can be a Literal, DataCon, or DEFAULT, but cannot be PrimOp
+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))]
@@ -118,8 +120,22 @@ but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
 \begin{code}
 data CoreRules 
   = Rules [CoreRule]
-	  IdOrTyVarSet		-- Locally-defined free vars of RHSs
+	  VarSet		-- Locally-defined free vars of RHSs
+
+emptyCoreRules :: CoreRules
+emptyCoreRules = Rules [] emptyVarSet
+
+isEmptyCoreRules :: CoreRules -> Bool
+isEmptyCoreRules (Rules rs _) = null rs
 
+rulesRhsFreeVars :: CoreRules -> VarSet
+rulesRhsFreeVars (Rules _ fvs) = fvs
+
+rulesRules :: CoreRules -> [CoreRule]
+rulesRules (Rules rules _) = rules
+\end{code}
+
+\begin{code}
 type RuleName = FAST_STRING
 
 data CoreRule
@@ -132,17 +148,137 @@ data CoreRule
 			-- and suchlike.  It has no free variables.
 	([CoreExpr] -> Maybe (RuleName, CoreExpr))
 
-emptyCoreRules :: CoreRules
-emptyCoreRules = Rules [] emptyVarSet
+isBuiltinRule (BuiltinRule _) = True
+isBuiltinRule _		      = False
+\end{code}
 
-isEmptyCoreRules :: CoreRules -> Bool
-isEmptyCoreRules (Rules rs _) = null rs
 
-rulesRhsFreeVars :: CoreRules -> IdOrTyVarSet
-rulesRhsFreeVars (Rules _ fvs) = fvs
+%************************************************************************
+%*									*
+\subsection{@Unfolding@ type}
+%*									*
+%************************************************************************
 
-rulesRules :: CoreRules -> [CoreRule]
-rulesRules (Rules rules _) = rules
+The @Unfolding@ type is declared here to avoid numerous loops, but it
+should be abstract everywhere except in CoreUnfold.lhs
+
+\begin{code}
+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}
+
+\begin{code}
+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
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{The main data type}
+%*									*
+%************************************************************************
+
+\begin{code}
+-- 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}
 
 
@@ -155,7 +291,7 @@ rulesRules (Rules rules _) = rules
 The common case
 
 \begin{code}
-type CoreBndr = IdOrTyVar
+type CoreBndr = Var
 type CoreExpr = Expr CoreBndr
 type CoreArg  = Arg  CoreBndr
 type CoreBind = Bind CoreBndr
@@ -185,7 +321,7 @@ type TaggedAlt  t = Alt  (Tagged t)
 mkApps    :: Expr b -> [Arg b]  -> Expr b
 mkTyApps  :: Expr b -> [Type]   -> Expr b
 mkValApps :: Expr b -> [Expr b] -> Expr b
-mkVarApps :: CoreExpr -> [IdOrTyVar] -> CoreExpr
+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
@@ -193,93 +329,26 @@ 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
-mkStringLit   :: String  -> Expr b
-mkStringLitFS :: FAST_STRING  -> Expr b
+mkIntLit      :: Integer -> Expr b
+mkIntLitInt   :: Int     -> Expr b
 mkConApp      :: DataCon -> [Arg b] -> Expr b
-mkPrimApp     :: PrimOp  -> [Arg b] -> Expr b
-
-mkLit lit	  = Con (Literal lit) []
-mkConApp con args = Con (DataCon con) args
-mkPrimApp op args = Con (PrimOp op)   args
+mkLets	      :: [Bind b] -> Expr b -> Expr b
+mkLams	      :: [b] -> Expr b -> Expr b
 
-mkStringLit str	= mkStringLitFS (_PK_ str)
+mkLit lit	  = Lit lit
+mkConApp con args = mkApps (Var (dataConId con)) args
 
-mkStringLitFS str
-  | any is_NUL (_UNPK_ str)
-  = 	 -- Must cater for NULs in literal string
-    mkApps (Var unpackCString2Id)
-		[mkLit (MachStr str),
-		 mkLit (mkMachInt (toInteger (_LENGTH_ str)))]
-
-  | otherwise
-  =	-- No NULs in the string
-    App (Var unpackCStringId) (mkLit (MachStr str))
+mkLams binders body = foldr Lam body binders
+mkLets binds body   = foldr Let body binds
 
-  where
-    is_NUL c = c == '\0'
+mkIntLit    n = Lit (mkMachInt n)
+mkIntLitInt n = Lit (mkMachInt (toInteger n))
 
-varToCoreExpr :: CoreBndr -> CoreExpr
+varToCoreExpr :: CoreBndr -> Expr b
 varToCoreExpr v | isId v    = Var v
                 | otherwise = Type (mkTyVarTy v)
 \end{code}
 
-\begin{code}
-mkLams :: [b] -> Expr b -> Expr b
-mkLams binders body = foldr Lam body binders
-\end{code}
-
-\begin{code}
-mkLets :: [Bind b] -> Expr b -> Expr b
-mkLets binds body = foldr Let body binds
-
-bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
--- (bindNonRec x r b) produces either
---	let x = r in b
--- or
---	case r of x { _DEFAULT_ -> b }
---
--- depending on whether x is unlifted or not
--- It's used by the desugarer to avoid building bindings
--- that give Core Lint a heart attack.  Actually the simplifier
--- deals with them perfectly well.
-bindNonRec bndr rhs body 
-  | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
-  | otherwise			 = Let (NonRec bndr rhs) body
-
-mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
-mkIfThenElse guard then_expr else_expr
-  = Case guard (mkWildId boolTy) 
-	 [ (DataCon trueDataCon,  [], then_expr),
-	   (DataCon falseDataCon, [], else_expr) ]
-\end{code}
-
-mkNote removes redundant coercions, and SCCs where possible
-
-\begin{code}
-mkNote :: Note -> Expr b -> Expr b
-mkNote (Coerce to_ty1 from_ty1) (Note (Coerce to_ty2 from_ty2) expr)
- = ASSERT( from_ty1 == to_ty2 )
-   mkNote (Coerce to_ty1 from_ty2) expr
-
-mkNote (SCC cc1) expr@(Note (SCC cc2) _)
-  | isDupdCC cc1	-- Discard the outer SCC provided we don't need
-  = expr		-- to track its entry count
-
-mkNote note@(SCC cc1) expr@(Lam x e)	-- Move _scc_ inside lambda
-  = Lam x (mkNote note e)
-
--- Drop trivial InlineMe's
-mkNote InlineMe expr@(Con _ _) = expr
-mkNote InlineMe expr@(Var v)   = expr
-
--- Slide InlineCall in around the function
---	No longer necessary I think (SLPJ Apr 99)
--- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
--- mkNote InlineCall (Var v)   = Note InlineCall (Var v)
--- mkNote InlineCall expr      = expr
-
-mkNote note expr = Note note expr
-\end{code}
 
 %************************************************************************
 %*									*
@@ -302,12 +371,6 @@ rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
 rhssOfAlts :: [Alt b] -> [Expr b]
 rhssOfAlts alts = [e | (_,_,e) <- alts]
 
-isDeadBinder :: CoreBndr -> Bool
-isDeadBinder bndr | isId bndr = case getIdOccInfo bndr of
-					IAmDead -> True
-					other	-> False
-		  | otherwise = False	-- TyVars count as not dead
-
 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
@@ -421,7 +484,7 @@ valArgCount (other  : args) = 1 + valArgCount args
 \begin{code}
 seqExpr :: CoreExpr -> ()
 seqExpr (Var v)       = v `seq` ()
-seqExpr (Con c as)    = seqExprs as
+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
@@ -457,39 +520,6 @@ seq_rules (Rule fs bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` se
 seq_rules (BuiltinRule _ : rules) = seq_rules rules
 \end{code}
 
-\begin{code}
-coreBindsSize :: [CoreBind] -> Int
-coreBindsSize bs = foldr ((+) . bindSize) 0 bs
-
-exprSize :: CoreExpr -> Int
-	-- A measure of the size of the expressions
-	-- It also forces the expression pretty drastically as a side effect
-exprSize (Var v)       = varSize v 
-exprSize (Con c as)    = c `seq` exprsSize as
-exprSize (App f a)     = exprSize f + exprSize a
-exprSize (Lam b e)     = varSize b + exprSize e
-exprSize (Let b e)     = bindSize b + exprSize e
-exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0  as
-exprSize (Note n e)    = exprSize e
-exprSize (Type t)      = seqType t `seq` 1
-
-exprsSize = foldr ((+) . exprSize) 0 
-
-varSize :: IdOrTyVar -> Int
-varSize b | isTyVar b = 1
-	  | otherwise = seqType (idType b)		`seq`
-			megaSeqIdInfo (idInfo b) 	`seq`
-			1
-
-varsSize = foldr ((+) . varSize) 0
-
-bindSize (NonRec b e) = varSize b + exprSize e
-bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs
-
-pairSize (b,e) = varSize b + exprSize e
-
-altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
-\end{code}
 
 
 %************************************************************************
@@ -503,7 +533,7 @@ type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
 
 data AnnExpr' bndr annot
   = AnnVar	Id
-  | AnnCon	Con [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]
@@ -511,7 +541,7 @@ data AnnExpr' bndr annot
   | AnnNote	Note (AnnExpr bndr annot)
   | AnnType	Type
 
-type AnnAlt bndr annot = (Con, [bndr], AnnExpr bndr annot)
+type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
 
 data AnnBind bndr annot
   = AnnNonRec bndr (AnnExpr bndr annot)
@@ -520,21 +550,22 @@ data AnnBind bndr annot
 
 \begin{code}
 deAnnotate :: AnnExpr bndr annot -> Expr bndr
+deAnnotate (_, e) = deAnnotate' e
 
-deAnnotate (_, AnnType	t)          = Type t
-deAnnotate (_, AnnVar	v)          = Var v
-deAnnotate (_, AnnCon	con args)   = Con con (map deAnnotate args)
-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' (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)
+deAnnotate' (AnnLet bind body)
   = Let (deAnnBind bind) (deAnnotate body)
   where
     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 
-deAnnotate (_, AnnCase scrut v alts)
+deAnnotate' (AnnCase scrut v alts)
   = Case (deAnnotate scrut) v (map deAnnAlt alts)
   where
     deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)