X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=f603969a63d244eb21682c238d2fb1e72a98a551;hb=b085ee40c7f265a5977ea6ec1c415e573be5ff8c;hp=febe1780bd43bf821baad287e7f84bf465a55cd6;hpb=a127213c1890584702075d732d7bb9887113e4ff;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index febe178..f603969 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -12,48 +12,52 @@ module CoreSyn ( mkLets, mkLams, mkApps, mkTyApps, mkValApps, mkVarApps, mkLit, mkIntLitInt, mkIntLit, - mkStringLit, mkStringLitFS, mkConApp, + 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 + emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules, + isBuiltinRule, ruleName ) where #include "HsVersions.h" +import CmdLineOpts ( opt_RuntimeTypes ) import CostCentre ( CostCentre, noCostCentre ) -import Var ( Var, Id, TyVar, isTyVar, isId, idType ) -import VarEnv -import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType ) -import Literal ( Literal(MachStr), mkMachInt ) -import PrimOp ( PrimOp ) -import DataCon ( DataCon, dataConId ) -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} @@ -75,7 +79,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 @@ -105,10 +109,34 @@ 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) +-- 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. + %************************************************************************ %* * @@ -124,18 +152,6 @@ data CoreRules = Rules [CoreRule] VarSet -- Locally-defined free vars of RHSs -type RuleName = FAST_STRING - -data CoreRule - = Rule RuleName - [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)) - emptyCoreRules :: CoreRules emptyCoreRules = Rules [] emptyVarSet @@ -149,6 +165,29 @@ 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 + RuleName -- and suchlike. It has no free variables. + ([CoreExpr] -> Maybe CoreExpr) + +isBuiltinRule (BuiltinRule _ _) = True +isBuiltinRule _ = False + +ruleName :: CoreRule -> RuleName +ruleName (Rule n _ _ _ _) = n +ruleName (BuiltinRule n _) = n +\end{code} + %************************************************************************ %* * @@ -177,12 +216,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. @@ -205,8 +243,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` () @@ -215,14 +253,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 @@ -230,31 +268,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} @@ -294,7 +338,6 @@ 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}: @@ -329,14 +372,12 @@ 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 @@ -344,22 +385,6 @@ 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) @@ -401,7 +426,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) @@ -412,16 +436,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 @@ -466,12 +480,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 @@ -532,8 +563,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} @@ -583,7 +614,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}