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

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 6a574c4..f941deb 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -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,16 +44,18 @@ 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 BasicTypes	( Activation )
 import VarSet
 import Outputable
 \end{code}
@@ -75,7 +78,7 @@ 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
+				-- 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 +107,34 @@ data Note
 
   | InlineMe		-- Instructs simplifer to treat the enclosed expression
 			-- as very small, and inline it at its call sites
+
+-- 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.
 
 
 %************************************************************************
@@ -163,16 +170,21 @@ type IdCoreRule = (Id,CoreRule)		-- Rules don't have their leading Id inside the
 
 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}
 
 
@@ -413,7 +425,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 +435,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 +479,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
@@ -544,8 +562,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 +613,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}