X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=a074499fd325b28f26b9559df46fbe73bcc9fcb2;hb=18074d6acde6d642b8fb10b1b49153f717c75446;hp=526fee5b8266f8afee07ba74a73edb323fa96b8d;hpb=111cee3f1ad93816cb828e38b38521d85c3bcebb;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 526fee5..a074499 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -7,54 +7,57 @@ 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, mkLit, mkIntLitInt, mkIntLit, - mkStringLit, mkStringLitFS, mkConApp, - mkAltExpr, - bindNonRec, mkIfThenElse, varToCoreExpr, + 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, - -- 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, neverUnfold, - -- Size - coreBindsSize, + -- 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 + emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules, + isBuiltinRule, ruleName ) where #include "HsVersions.h" -import TysWiredIn ( boolTy, stringTy, nilDataCon ) +import CmdLineOpts ( opt_RuntimeTypes ) import CostCentre ( CostCentre, noCostCentre ) -import Var ( Var, Id, TyVar, isTyVar, isId, idType ) -import VarEnv -import Id ( mkWildId, idOccInfo, idInfo ) -import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType ) -import IdInfo ( OccInfo(..), megaSeqIdInfo ) -import Literal ( Literal(MachStr), mkMachInt ) -import PrimOp ( PrimOp ) -import DataCon ( DataCon, dataConId ) -import TysWiredIn ( trueDataCon, falseDataCon ) -import ThinAir ( unpackCStringId, unpackCString2Id, addr2IntegerId ) +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} @@ -76,11 +79,27 @@ 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, + -- meaning that it covers all cases that can occur + -- See the example below + -- + -- 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 +-- An "exhausive" case does not necessarily mention all constructors: +-- data Foo = Red | Green | Blue +-- +-- ...case x of +-- Red -> True +-- other -> f (case x of +-- Green -> ... +-- Blue -> ... ) +-- The inner case does not need a Red alternative, because x can't be Red at +-- that program point. + + type Arg b = Expr b -- Can be a Type type Alt b = (AltCon, [b], Expr b) -- (DEFAULT, [], rhs) is the default alternative @@ -106,10 +125,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. + %************************************************************************ %* * @@ -125,29 +170,153 @@ data CoreRules = Rules [CoreRule] VarSet -- Locally-defined free vars of RHSs -type RuleName = FAST_STRING +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 = 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) -emptyCoreRules :: CoreRules -emptyCoreRules = Rules [] emptyVarSet +isBuiltinRule (BuiltinRule _ _) = True +isBuiltinRule _ = False -isEmptyCoreRules :: CoreRules -> Bool -isEmptyCoreRules (Rules rs _) = null rs +ruleName :: CoreRule -> RuleName +ruleName (Rule n _ _ _ _) = n +ruleName (BuiltinRule n _) = n +\end{code} -rulesRhsFreeVars :: CoreRules -> VarSet -rulesRhsFreeVars (Rules _ fvs) = fvs -rulesRules :: CoreRules -> [CoreRule] -rulesRules (Rules rules _) = rules +%************************************************************************ +%* * +\subsection{@Unfolding@ type} +%* * +%************************************************************************ + +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 + +neverUnfold :: Unfolding -> Bool +neverUnfold NoUnfolding = True +neverUnfold (OtherCon _) = True +neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True +neverUnfold other = False \end{code} @@ -187,18 +356,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 (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} @@ -222,78 +396,24 @@ mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars mkLit :: Literal -> Expr b mkIntLit :: Integer -> Expr b mkIntLitInt :: Int -> Expr b -mkStringLit :: String -> Expr b -- Makes a [Char] literal -mkStringLitFS :: FAST_STRING -> Expr b -- Makes a [Char] literal mkConApp :: DataCon -> [Arg b] -> Expr b +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 mkIntLit n = Lit (mkMachInt n) mkIntLitInt n = Lit (mkMachInt (toInteger n)) -mkStringLit str = mkStringLitFS (_PK_ str) - -mkStringLitFS str - | any is_NUL (_UNPK_ str) - = -- Must cater for NULs in literal string - mkApps (Var unpackCString2Id) - [Lit (MachStr str), - mkIntLitInt (_LENGTH_ str)] - - | otherwise - = -- No NULs in the string - App (Var unpackCStringId) (Lit (MachStr str)) - - where - is_NUL c = c == '\0' - 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) - [ (DataAlt trueDataCon, [], then_expr), - (DataAlt falseDataCon, [], else_expr) ] -\end{code} - - -\begin{code} -mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr - -- This guy constructs the value that the scrutinee must have - -- when you are in one particular branch of a case -mkAltExpr (DataAlt con) args inst_tys - = mkConApp con (map Type inst_tys ++ map varToCoreExpr args) -mkAltExpr (LitAlt lit) [] [] - = Lit lit -\end{code} - %************************************************************************ %* * @@ -330,7 +450,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) @@ -341,16 +460,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 @@ -395,12 +504,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 @@ -441,6 +567,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` () @@ -461,44 +588,10 @@ 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} -\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 (Lit lit) = 1 -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 :: Var -> 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} %************************************************************************ @@ -546,7 +639,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}