X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=4c70bb33e1c0b963947407fe3f665c6d95892161;hb=49bff3215bf3fe9ada24dac2cf80f97db4e597dd;hp=43e82a71bf7fab73303d13c64e040286a54e6e0e;hpb=c9107a839eb7959d166b470f4526679cb55173c7;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 43e82a7..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,43 +15,49 @@ module CoreSyn ( mkConApp, varToCoreExpr, - bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isTyVar, isId, + 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 noUnfolding, mkOtherCon, unfoldingTemplate, maybeUnfoldingTemplate, otherCons, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding, - hasUnfolding, hasSomeUnfolding, + hasUnfolding, hasSomeUnfolding, neverUnfold, -- Seq stuff 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 CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only + 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, idType ) -import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType ) -import Literal ( Literal(MachStr), mkMachInt ) -import DataCon ( DataCon, dataConId ) +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 \end{code} @@ -73,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 @@ -103,10 +110,36 @@ data Note | InlineMe -- Instructs simplifer to treat the enclosed expression -- as very small, and inline it at its call sites - | TermUsg -- A term-level usage annotation - UsageAnn -- (should not be a variable except during UsageSP inference) + | 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. + %************************************************************************ %* * @@ -136,20 +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} @@ -180,12 +219,11 @@ data Unfolding | CoreUnfolding -- An unfolding with redundant cached information CoreExpr -- Template; binder-info is correct - Bool -- This is a top-level binding - Bool -- exprIsCheap template (cached); it won't duplicate (much) work - -- if you inline this in more than one place + Bool -- True <=> top level binding Bool -- exprIsValue template (cached); it is ok to discard a `seq` on -- this variable - Bool -- exprIsBottom template (cached) + Bool -- True <=> doesn't waste (much) work to expand inside an inlining + -- Basically it's exprIsCheap UnfoldingGuidance -- Tells about the *size* of the template. @@ -208,8 +246,8 @@ noUnfolding = NoUnfolding mkOtherCon = OtherCon seqUnfolding :: Unfolding -> () -seqUnfolding (CoreUnfolding e top b1 b2 b3 g) - = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` seqGuidance g +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` () @@ -218,14 +256,14 @@ seqGuidance other = () \begin{code} unfoldingTemplate :: Unfolding -> CoreExpr -unfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = expr -unfoldingTemplate (CompulsoryUnfolding expr) = expr +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 +maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr +maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr +maybeUnfoldingTemplate other = Nothing otherCons :: Unfolding -> [AltCon] otherCons (OtherCon cons) = cons @@ -233,31 +271,37 @@ otherCons other = [] isValueUnfolding :: Unfolding -> Bool -- Returns False for OtherCon -isValueUnfolding (CoreUnfolding _ _ _ is_evald _ _) = is_evald -isValueUnfolding other = False +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 +isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald +isEvaldUnfolding other = False isCheapUnfolding :: Unfolding -> Bool -isCheapUnfolding (CoreUnfolding _ _ is_cheap _ _ _) = is_cheap -isCheapUnfolding other = False +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 +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} @@ -297,18 +341,23 @@ type CoreExpr = Expr CoreBndr type CoreArg = Arg CoreBndr type CoreBind = Bind CoreBndr type CoreAlt = Alt CoreBndr -type CoreNote = Note \end{code} 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 (Tagged t) -type TaggedExpr t = Expr (Tagged t) -type TaggedArg t = Arg (Tagged t) -type TaggedAlt t = Alt (Tagged t) +type TaggedBind t = Bind (TaggedBndr t) +type TaggedExpr t = Expr (TaggedBndr t) +type TaggedArg t = Arg (TaggedBndr t) +type TaggedAlt t = Alt (TaggedBndr 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} @@ -337,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 @@ -386,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) @@ -397,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 @@ -451,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 @@ -497,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` () @@ -517,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} @@ -568,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}