X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=4c70bb33e1c0b963947407fe3f665c6d95892161;hb=49bff3215bf3fe9ada24dac2cf80f97db4e597dd;hp=6a574c4c7812416608d979a295d95d29a9a4b07e;hpb=db95d6e8d319b0c5cee1ccc23751e8190152ade3;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 6a574c4..4c70bb3 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -7,7 +7,7 @@
 module CoreSyn (
 	Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
 	CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
-	TaggedExpr, TaggedAlt, TaggedBind, TaggedArg,
+	TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
 
 	mkLets, mkLams, 
 	mkApps, mkTyApps, mkValApps, mkVarApps,
@@ -15,14 +15,14 @@ module CoreSyn (
 	mkConApp, 
 	varToCoreExpr,
 
-	isTyVar, isId, isLocalVar, mustHaveLocalBinding,
+	isTyVar, isId, 
 	bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 
 	collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
-	collectArgs, collectBindersIgnoringNotes,
+	collectArgs, 
 	coreExprCc,
 	flattenBinds, 
 
-	isValArg, isTypeArg, valArgCount, valBndrCount,
+	isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
 
 	-- Unfoldings
 	Unfolding(..),	UnfoldingGuidance(..), 	-- Both abstract everywhere but in CoreUnfold.lhs
@@ -35,7 +35,8 @@ module CoreSyn (
 	seqRules, seqExpr, seqExprs, seqUnfolding,
 
 	-- Annotated expressions
-	AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate, deAnnotate',
+	AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, 
+	deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
 
 	-- Core rules
 	CoreRules(..), 	-- Representation needed by friends
@@ -43,17 +44,20 @@ module CoreSyn (
 	IdCoreRule,
 	RuleName,
 	emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
-	isBuiltinRule
+	isBuiltinRule, ruleName
     ) where
 
 #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, dataConId )
+import DataCon		( DataCon, dataConWorkId )
+import BasicTypes	( Activation )
 import VarSet
+import FastString
 import Outputable
 \end{code}
 
@@ -75,7 +79,8 @@ data Expr b	-- "b" for the type of binders,
   | Lam   b (Expr b)
   | Let   (Bind b) (Expr b)
   | Case  (Expr b) b [Alt b]  	-- Binder gets bound to value of scrutinee
-				-- DEFAULT case must be last, if it occurs at all
+	-- Invariant: the list of alternatives is ALWAYS EXHAUSTIVE
+	-- 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
@@ -104,30 +109,36 @@ data Note
 
   | 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:
 
-%************************************************************************
-%*									*
-\subsection{isLocalVar}
-%*									*
-%************************************************************************
+* The RHS of a letrec, and the RHSs of all top-level lets,
+  must be of LIFTED type.
 
-@isLocalVar@ returns True of all TyVars, and of Ids that are defined in 
-this module and are not constants like data constructors and record selectors.
-These are the variables that we need to pay attention to when finding free
-variables, or doing dependency analysis.
+* 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]
 
-\begin{code}
-isLocalVar :: Var -> Bool
-isLocalVar v = isTyVar v || isLocalId v
-\end{code}
+* The argument of an App can be of any type.
 
-\begin{code}
-mustHaveLocalBinding :: Var -> Bool
--- True <=> the variable must have a binding in this module
-mustHaveLocalBinding v = isTyVar v || (isLocalId v && not (hasNoBinding v))
-\end{code}
+* 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.
 
 
 %************************************************************************
@@ -158,21 +169,26 @@ rulesRules (Rules rules _) = rules
 \end{code}
 
 \begin{code}
-type RuleName = FAST_STRING
+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
-			-- and suchlike.  It has no free variables.
-	([CoreExpr] -> Maybe (RuleName, CoreExpr))
+	RuleName	-- and suchlike.  It has no free variables.
+	([CoreExpr] -> Maybe CoreExpr)
 
-isBuiltinRule (BuiltinRule _) = True
-isBuiltinRule _		      = False
+isBuiltinRule (BuiltinRule _ _) = True
+isBuiltinRule _		        = False
+
+ruleName :: CoreRule -> RuleName
+ruleName (Rule n _ _ _ _)  = n
+ruleName (BuiltinRule n _) = n
 \end{code}
 
 
@@ -330,12 +346,18 @@ type CoreAlt  = Alt  CoreBndr
 Binders are ``tagged'' with a \tr{t}:
 
 \begin{code}
-type Tagged t = (CoreBndr, t)
+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)
 
-type TaggedBind t = Bind (Tagged t)
-type TaggedExpr t = Expr (Tagged t)
-type TaggedArg  t = Arg  (Tagged t)
-type TaggedAlt  t = Alt  (Tagged t)
+instance Outputable b => Outputable (TaggedBndr b) where
+  ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
+
+instance Outputable b => OutputableBndr (TaggedBndr b) where
+  pprBndr _ b = ppr b	-- Simple
 \end{code}
 
 
@@ -364,7 +386,7 @@ mkLets	      :: [Bind b] -> Expr b -> Expr b
 mkLams	      :: [b] -> Expr b -> Expr b
 
 mkLit lit	  = Lit lit
-mkConApp con args = mkApps (Var (dataConId con)) args
+mkConApp con args = mkApps (Var (dataConWorkId con)) args
 
 mkLams binders body = foldr Lam body binders
 mkLets binds body   = foldr Let body binds
@@ -413,7 +435,6 @@ order.
 
 \begin{code}
 collectBinders	             :: Expr b -> ([b],         Expr b)
-collectBindersIgnoringNotes  :: Expr b -> ([b],         Expr b)
 collectTyBinders       	     :: CoreExpr -> ([TyVar],     CoreExpr)
 collectValBinders      	     :: CoreExpr -> ([Id],        CoreExpr)
 collectTyAndValBinders 	     :: CoreExpr -> ([TyVar], [Id], CoreExpr)
@@ -424,16 +445,6 @@ collectBinders expr
     go bs (Lam b e) = go (b:bs) e
     go bs e	     = (reverse bs, e)
 
--- This one ignores notes.  It's used in CoreUnfold and StrAnal
--- when we aren't going to put the expression back together from
--- the pieces, so we don't mind losing the Notes
-collectBindersIgnoringNotes expr
-  = go [] expr
-  where
-    go bs (Lam b e)  = go (b:bs) e
-    go bs (Note _ e) = go    bs  e
-    go bs e	     = (reverse bs, e)
-
 collectTyAndValBinders expr
   = (tvs, ids, body)
   where
@@ -478,12 +489,29 @@ coreExprCc other               = noCostCentre
 \end{code}
 
 
+
 %************************************************************************
 %*									*
 \subsection{Predicates}
 %*									*
 %************************************************************************
 
+@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}
+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}
 isValArg (Type _) = False
 isValArg other    = True
@@ -524,6 +552,7 @@ 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` ()
@@ -544,8 +573,8 @@ 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
+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}
 
 
@@ -595,7 +624,16 @@ deAnnotate' (AnnLet bind body)
 
 deAnnotate' (AnnCase scrut v alts)
   = Case (deAnnotate scrut) v (map deAnnAlt alts)
-  where
-    deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
+
+deAnnAlt :: AnnAlt bndr annot -> Alt bndr
+deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 \end{code}
 
+\begin{code}
+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}