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}