X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=c1eb1f060daed67d227ccd071443cec3f4856130;hb=4e7d56fde0f44d38bbb9a6fc72cf9c603264899d;hp=4d1f95464c53647b50b51633c0f5fee48b9d838c;hpb=b2bcd65847b48f62fd72497ccf43d867901ecf26;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 4d1f954..c1eb1f0 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -1,202 +1,170 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[CoreSyn]{A data type for the Haskell compiler midsection} \begin{code} module CoreSyn ( - GenCoreBinding(..), GenCoreExpr(..), - GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..), - GenCoreCaseDefault(..), CoreNote(..), - - bindersOf, pairsFromCoreBinds, rhssOfBind, - - mkGenApp, mkValApp, mkTyApp, - mkApp, mkCon, mkPrim, - mkValLam, mkTyLam, - mkLam, - collectBinders, collectValBinders, collectTyBinders, - isValBinder, notValBinder, - - collectArgs, initialTyArgs, initialValArgs, isValArg, notValArg, numValArgs, - - mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase, - mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase, - mkCoLetrecAny, mkCoLetrecNoUnboxed, - - rhssOfAlts, - - -- Common type instantiation... - CoreBinding, - CoreExpr, - CoreBinder, - CoreArg, - CoreCaseAlts, - CoreCaseDefault, - - -- And not-so-common type instantiations... - TaggedCoreBinding, - TaggedCoreExpr, - TaggedCoreBinder, - TaggedCoreArg, - TaggedCoreCaseAlts, - TaggedCoreCaseDefault, - - SimplifiableCoreBinding, - SimplifiableCoreExpr, - SimplifiableCoreBinder, - SimplifiableCoreArg, - SimplifiableCoreCaseAlts, - SimplifiableCoreCaseDefault + Expr(..), Alt, Bind(..), Arg(..), Note(..), + CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, + TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, + + mkLets, mkLams, + mkApps, mkTyApps, mkValApps, mkVarApps, + mkLit, mkStringLit, mkConApp, mkPrimApp, mkNote, + bindNonRec, mkIfThenElse, varToCoreExpr, + + bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isDeadBinder, isTyVar, isId, + collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, + collectArgs, collectBindersIgnoringNotes, + coreExprCc, + flattenBinds, + + isValArg, isTypeArg, valArgCount, valBndrCount, + + -- Seq stuff + seqRules, seqExpr, seqExprs, + + -- Size + coreBindsSize, + + -- Annotated expressions + AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate, + + -- Core rules + CoreRules(..), -- Representation needed by friends + CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only + emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules ) where #include "HsVersions.h" -import CostCentre ( CostCentre ) -import Id ( idType, Id ) -import Type ( isUnboxedType,GenType, Type ) -import TyVar ( GenTyVar, TyVar ) -import Util ( panic, assertPanic ) -import BinderInfo ( BinderInfo ) -import BasicTypes ( Unused ) -import Literal ( Literal ) -import PrimOp ( PrimOp ) +import TysWiredIn ( boolTy, stringTy, nilDataCon ) +import CostCentre ( CostCentre, isDupdCC, noCostCentre ) +import Var ( Var, Id, TyVar, IdOrTyVar, isTyVar, isId, idType ) +import VarEnv +import Id ( mkWildId, getInlinePragma, idInfo ) +import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType ) +import IdInfo ( InlinePragInfo(..), megaSeqIdInfo ) +import Const ( Con(..), DataCon, Literal(NoRepStr), PrimOp ) +import TysWiredIn ( trueDataCon, falseDataCon ) +import VarSet +import Outputable \end{code} %************************************************************************ %* * -\subsection[CoreTopBinding_and_CoreBinding]{@CoreTopBinding@ and @GenCoreBinding@} +\subsection{The main data types} %* * %************************************************************************ -Core programs, bindings, expressions, etc., are parameterised with -respect to the information kept about binding and bound occurrences of -variables, called {\em binders} and {\em val_occ tyvar uvars}, respectively. [I -don't really like the pair of names; I prefer {\em binder} and {\em -bounder}. Or {\em binder} and {\em var}.] +These data types are the heart of the compiler -A @GenCoreBinding@ is either a single non-recursive binding of a -``binder'' to an expression, or a mutually-recursive blob of same. \begin{code} -data GenCoreBinding val_bdr val_occ flexi - = NonRec val_bdr (GenCoreExpr val_bdr val_occ flexi) - | Rec [(val_bdr, GenCoreExpr val_bdr val_occ flexi)] -\end{code} - -\begin{code} -bindersOf :: GenCoreBinding val_bdr val_occ flexi -> [val_bdr] - -pairsFromCoreBinds :: - [GenCoreBinding val_bdr val_occ flexi] -> - [(val_bdr, GenCoreExpr val_bdr val_occ flexi)] +infixl 8 `App` -- App brackets to the left + +data Expr b -- "b" for the type of binders, + = Var Id + | Con Con [Arg b] -- Guaranteed saturated + -- The Con can be a DataCon, Literal, PrimOP + -- but cannot be DEFAULT + | App (Expr b) (Arg b) + | 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 + | Note Note (Expr b) + | Type Type -- This should only show up at the top + -- level of an Arg + +type Arg b = Expr b -- Can be a Type + +type Alt b = (Con, [b], Expr b) + -- (DEFAULT, [], rhs) is the default alternative + -- The Con can be a Literal, DataCon, or DEFAULT, but cannot be PrimOp + +data Bind b = NonRec b (Expr b) + | Rec [(b, (Expr b))] + +data Note + = SCC CostCentre -rhssOfBind :: GenCoreBinding val_bdr val_occ flexi -> [GenCoreExpr val_bdr val_occ flexi] + | Coerce + Type -- The to-type: type of whole coerce expression + Type -- The from-type: type of enclosed expression -bindersOf (NonRec binder _) = [binder] -bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] + | InlineCall -- Instructs simplifier to inline + -- the enclosed call -pairsFromCoreBinds [] = [] -pairsFromCoreBinds ((NonRec b e) : bs) = (b,e) : pairsFromCoreBinds bs -pairsFromCoreBinds ((Rec pairs) : bs) = pairs ++ pairsFromCoreBinds bs + | InlineMe -- Instructs simplifer to treat the enclosed expression + -- as very small, and inline it at its call sites -rhssOfBind (NonRec _ rhs) = [rhs] -rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] + | TermUsg -- A term-level usage annotation + UsageAnn -- (should not be a variable except during UsageSP inference) \end{code} + %************************************************************************ %* * -\subsection[GenCoreExpr]{Core expressions: @GenCoreExpr@} +\subsection{Transformation rules} %* * %************************************************************************ -@GenCoreExpr@ is the heart of the ``core'' data types; it is -(more-or-less) boiled-down second-order polymorphic lambda calculus. -For types in the core world, we just keep using @Types@. -\begin{code} -data GenCoreExpr val_bdr val_occ flexi - = Var val_occ - | Lit Literal -- literal constants -\end{code} - -@Cons@ and @Prims@ are saturated constructor and primitive-op -applications (see the comment). Note: @Con@s are only set up by the -simplifier (and by the desugarer when it knows what it's doing). The -desugarer sets up constructors as applications of global @Vars@s. - -\begin{code} - | Con Id [GenCoreArg val_occ flexi] - -- Saturated constructor application: - -- The constructor is a function of the form: - -- /\ a1 -> ... /\ am -> \ b1 -> ... \ bn -> - -- where "/\" is a type lambda and "\" the - -- regular kind; there will be "m" Types and - -- "n" bindees in the Con args. - - | Prim PrimOp [GenCoreArg val_occ flexi] - -- saturated primitive operation; - - -- comment on Cons applies here, too. -\end{code} +The CoreRule type and its friends are dealt with mainly in CoreRules, +but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation. -Ye olde abstraction and application operators. \begin{code} - | Lam (GenCoreBinder val_bdr flexi) - (GenCoreExpr val_bdr val_occ flexi) +data CoreRules + = Rules [CoreRule] + IdOrTyVarSet -- Locally-defined free vars of RHSs - | App (GenCoreExpr val_bdr val_occ flexi) - (GenCoreArg val_occ flexi) -\end{code} +data CoreRule + = Rule FAST_STRING -- Rule name + [CoreBndr] -- Forall'd variables + [CoreExpr] -- LHS args + CoreExpr -- RHS -Case expressions (\tr{case of }): there -are really two flavours masquerading here---those for scrutinising -{\em algebraic} types and those for {\em primitive} types. Please see -under @GenCoreCaseAlts@. -\begin{code} - | Case (GenCoreExpr val_bdr val_occ flexi) - (GenCoreCaseAlts val_bdr val_occ flexi) -\end{code} +emptyCoreRules :: CoreRules +emptyCoreRules = Rules [] emptyVarSet -A Core case expression \tr{case e of v -> ...} implies evaluation of -\tr{e}; it is not equivalent to \tr{let v = in ...} (as with a Haskell -\tr{case}). +isEmptyCoreRules :: CoreRules -> Bool +isEmptyCoreRules (Rules rs _) = null rs -Non-recursive @Lets@ only have one binding; having more than one -doesn't buy you much, and it is an easy way to mess up variable -scoping. -\begin{code} - | Let (GenCoreBinding val_bdr val_occ flexi) - (GenCoreExpr val_bdr val_occ flexi) - -- both recursive and non-. - -- The "GenCoreBinding" records that information -\end{code} +rulesRhsFreeVars :: CoreRules -> IdOrTyVarSet +rulesRhsFreeVars (Rules _ fvs) = fvs -A @Note@ annotates a @CoreExpr@ with useful information -of some kind. -\begin{code} - | Note (CoreNote flexi) - (GenCoreExpr val_bdr val_occ flexi) +rulesRules :: CoreRules -> [CoreRule] +rulesRules (Rules rules _) = rules \end{code} %************************************************************************ %* * -\subsection{Core-notes} +\subsection{Useful synonyms} %* * %************************************************************************ +The common case + \begin{code} -data CoreNote flexi - = SCC - CostCentre +type CoreBndr = IdOrTyVar +type CoreExpr = Expr CoreBndr +type CoreArg = Arg CoreBndr +type CoreBind = Bind CoreBndr +type CoreAlt = Alt CoreBndr +type CoreNote = Note +\end{code} - | Coerce - (GenType flexi) -- The to-type: type of whole coerce expression - (GenType flexi) -- The from-type: type of enclosed expression +Binders are ``tagged'' with a \tr{t}: - | InlineCall -- Instructs simplifier to inline - -- the enclosed call -\end{code} +\begin{code} +type Tagged t = (CoreBndr, 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) +\end{code} %************************************************************************ @@ -205,347 +173,345 @@ data CoreNote flexi %* * %************************************************************************ -When making @Lets@, we may want to take evasive action if the thing -being bound has unboxed type. We have different variants ... - -@mkCoLet(s|rec)Any@ let-binds any binding, regardless of type -@mkCoLet(s|rec)NoUnboxed@ prohibits unboxed bindings -@mkCoLet(s)UnboxedToCase@ converts an unboxed binding to a case - (unboxed bindings in a letrec are still prohibited) - \begin{code} -mkCoLetAny :: GenCoreBinding Id Id flexi - -> GenCoreExpr Id Id flexi - -> GenCoreExpr Id Id flexi -mkCoLetsAny :: [GenCoreBinding Id Id flexi] -> - GenCoreExpr Id Id flexi -> - GenCoreExpr Id Id flexi - -mkCoLetrecAny :: [(val_bdr, GenCoreExpr val_bdr val_occ flexi)] - -> GenCoreExpr val_bdr val_occ flexi - -> GenCoreExpr val_bdr val_occ flexi - -mkCoLetrecAny [] body = body -mkCoLetrecAny binds body = Let (Rec binds) body - -mkCoLetsAny [] expr = expr -mkCoLetsAny binds expr = foldr mkCoLetAny expr binds - -mkCoLetAny bind@(Rec binds) body = mkCoLetrecAny binds body -mkCoLetAny bind@(NonRec binder rhs) body = Let bind body +mkApps :: Expr b -> [Arg b] -> Expr b +mkTyApps :: Expr b -> [Type] -> Expr b +mkValApps :: Expr b -> [Expr b] -> Expr b +mkVarApps :: CoreExpr -> [IdOrTyVar] -> CoreExpr + +mkApps f args = foldl App f args +mkTyApps f args = foldl (\ e a -> App e (Type a)) f args +mkValApps f args = foldl (\ e a -> App e a) f args +mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars + +mkLit :: Literal -> Expr b +mkStringLit :: String -> Expr b +mkConApp :: DataCon -> [Arg b] -> Expr b +mkPrimApp :: PrimOp -> [Arg b] -> Expr b + +mkLit lit = Con (Literal lit) [] +mkStringLit str = Con (Literal (NoRepStr (_PK_ str) stringTy)) [] +mkConApp con args = Con (DataCon con) args +mkPrimApp op args = Con (PrimOp op) args + +varToCoreExpr :: CoreBndr -> CoreExpr +varToCoreExpr v | isId v = Var v + | otherwise = Type (mkTyVarTy v) \end{code} \begin{code} -mkCoLetNoUnboxed bind@(Rec binds) body - = mkCoLetrecNoUnboxed binds body - -mkCoLetNoUnboxed bind@(NonRec binder rhs) body - = --ASSERT (not (isUnboxedType (idType binder))) - case body of - Var binder2 | binder == binder2 - -> rhs -- hey, I have the rhs - other - -> Let bind body - -mkCoLetsNoUnboxed [] expr = expr -mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds - -mkCoLetrecNoUnboxed [] body = body -mkCoLetrecNoUnboxed binds body - = ASSERT (all is_boxed_bind binds) - Let (Rec binds) body - where - is_boxed_bind (binder, rhs) - = (not . isUnboxedType . idType) binder +mkLams :: [b] -> Expr b -> Expr b +mkLams binders body = foldr Lam body binders \end{code} \begin{code} -mkCoLetUnboxedToCase bind@(Rec binds) body - = mkCoLetrecNoUnboxed binds body - -mkCoLetUnboxedToCase bind@(NonRec binder rhs) body - = case body of - Var binder2 | binder == binder2 - -> rhs -- hey, I have the rhs - other - -> if (not (isUnboxedType (idType binder))) then - Let bind body -- boxed... - else - Case rhs -- unboxed... - (PrimAlts [] - (BindDefault binder body)) - -mkCoLetsUnboxedToCase [] expr = expr -mkCoLetsUnboxedToCase binds expr = foldr mkCoLetUnboxedToCase expr binds +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) + [ (DataCon trueDataCon, [], then_expr), + (DataCon falseDataCon, [], else_expr) ] \end{code} -%************************************************************************ -%* * -\subsection{Case alternatives in @GenCoreExpr@} -%* * -%************************************************************************ - -We have different kinds of @case@s, the differences being reflected in -the kinds of alternatives a case has. We maintain a distinction -between cases for scrutinising algebraic datatypes, as opposed to -primitive types. In both cases, we carry around a @TyCon@, as a -handle with which we can get info about the case (e.g., total number -of data constructors for this type). - -For example: -\begin{verbatim} -let# x=e in b -\end{verbatim} -becomes -\begin{verbatim} -Case e [ BindDefaultAlt x -> b ] -\end{verbatim} +mkNote removes redundant coercions, and SCCs where possible \begin{code} -data GenCoreCaseAlts val_bdr val_occ flexi - = AlgAlts [(Id, -- alts: data constructor, - [val_bdr], -- constructor's parameters, - GenCoreExpr val_bdr val_occ flexi)] -- rhs. - (GenCoreCaseDefault val_bdr val_occ flexi) - - | PrimAlts [(Literal, -- alts: unboxed literal, - GenCoreExpr val_bdr val_occ flexi)] -- rhs. - (GenCoreCaseDefault val_bdr val_occ flexi) - --- obvious things: if there are no alts in the list, then the default --- can't be NoDefault. - -data GenCoreCaseDefault val_bdr val_occ flexi - = NoDefault -- small con family: all - -- constructor accounted for - | BindDefault val_bdr -- form: var -> expr; - (GenCoreExpr val_bdr val_occ flexi) -- "val_bdr" may or may not - -- be used in RHS. -\end{code} +mkNote :: Note -> Expr b -> Expr b +mkNote (Coerce to_ty1 from_ty1) (Note (Coerce to_ty2 from_ty2) expr) + = ASSERT( from_ty1 == to_ty2 ) + mkNote (Coerce to_ty1 from_ty2) expr -\begin{code} -rhssOfAlts (AlgAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,_,rhs) <- alts] -rhssOfAlts (PrimAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,rhs) <- alts] +mkNote (SCC cc1) expr@(Note (SCC cc2) _) + | isDupdCC cc1 -- Discard the outer SCC provided we don't need + = expr -- to track its entry count + +mkNote note@(SCC cc1) expr@(Lam x e) -- Move _scc_ inside lambda + = Lam x (mkNote note e) + +-- Drop trivial InlineMe's +mkNote InlineMe expr@(Con _ _) = expr +mkNote InlineMe expr@(Var v) = expr + +-- Slide InlineCall in around the function +-- No longer necessary I think (SLPJ Apr 99) +-- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a +-- mkNote InlineCall (Var v) = Note InlineCall (Var v) +-- mkNote InlineCall expr = expr -rhssOfDeflt NoDefault = [] -rhssOfDeflt (BindDefault _ rhs) = [rhs] +mkNote note expr = Note note expr \end{code} %************************************************************************ %* * -\subsection{Core binders} +\subsection{Simple access functions} %* * %************************************************************************ \begin{code} -data GenCoreBinder val_bdr flexi - = ValBinder val_bdr - | TyBinder (GenTyVar flexi) +bindersOf :: Bind b -> [b] +bindersOf (NonRec binder _) = [binder] +bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] -isValBinder (ValBinder _) = True -isValBinder _ = False +bindersOfBinds :: [Bind b] -> [b] +bindersOfBinds binds = foldr ((++) . bindersOf) [] binds -notValBinder = not . isValBinder -\end{code} +rhssOfBind :: Bind b -> [Expr b] +rhssOfBind (NonRec _ rhs) = [rhs] +rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] -Clump Lams together if possible. +rhssOfAlts :: [Alt b] -> [Expr b] +rhssOfAlts alts = [e | (_,_,e) <- alts] -\begin{code} -mkValLam :: [val_bdr] - -> GenCoreExpr val_bdr val_occ flexi - -> GenCoreExpr val_bdr val_occ flexi -mkTyLam :: [GenTyVar flexi] - -> GenCoreExpr val_bdr val_occ flexi - -> GenCoreExpr val_bdr val_occ flexi - -mkValLam binders body = foldr (Lam . ValBinder) body binders -mkTyLam binders body = foldr (Lam . TyBinder) body binders - -mkLam :: [GenTyVar flexi] -> [val_bdr] -- ToDo: could add a [uvar] arg... - -> GenCoreExpr val_bdr val_occ flexi - -> GenCoreExpr val_bdr val_occ flexi - -mkLam tyvars valvars body - = mkTyLam tyvars (mkValLam valvars body) +isDeadBinder :: CoreBndr -> Bool +isDeadBinder bndr | isId bndr = case getInlinePragma bndr of + IAmDead -> True + other -> False + | otherwise = False -- TyVars count as not dead + +flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs +flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds +flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds +flattenBinds [] = [] \end{code} We often want to strip off leading lambdas before getting down to business. @collectBinders@ is your friend. -We expect (by convention) usage-, type-, and value- lambdas in that +We expect (by convention) type-, and value- lambdas in that order. \begin{code} -collectBinders :: - GenCoreExpr val_bdr val_occ flexi -> - ([GenTyVar flexi], [val_bdr], GenCoreExpr val_bdr val_occ flexi) +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) collectBinders expr - = case collectValBinders body1 of { (vals,body) -> (tyvars, vals, body) } + = go [] expr + where + 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 - (tyvars, body1) = collectTyBinders expr + (tvs, body1) = collectTyBinders expr + (ids, body) = collectValBinders body1 collectTyBinders expr - = tyvars expr [] + = go [] expr where - tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc) - tyvars other tacc = (reverse tacc, other) + go tvs (Lam b e) | isTyVar b = go (b:tvs) e + go tvs e = (reverse tvs, e) -collectValBinders :: GenCoreExpr val_bdr val_occ flexi -> - ([val_bdr], GenCoreExpr val_bdr val_occ flexi) collectValBinders expr = go [] expr where - go acc (Lam (ValBinder v) b) = go (v:acc) b - go acc body = (reverse acc, body) - -\end{code} - -%************************************************************************ -%* * -\subsection{Core arguments (atoms)} -%* * -%************************************************************************ - -\begin{code} -data GenCoreArg val_occ flexi - = LitArg Literal - | VarArg val_occ - | TyArg (GenType flexi) -\end{code} - -General and specific forms: -\begin{code} -mkGenApp :: GenCoreExpr val_bdr val_occ flexi - -> [GenCoreArg val_occ flexi] - -> GenCoreExpr val_bdr val_occ flexi -mkTyApp :: GenCoreExpr val_bdr val_occ flexi - -> [GenType flexi] - -> GenCoreExpr val_bdr val_occ flexi -mkValApp :: GenCoreExpr val_bdr val_occ flexi - -> [GenCoreArg val_occ flexi] -- but we ASSERT they are LitArg or VarArg - -> GenCoreExpr val_bdr val_occ flexi - -mkGenApp f args = foldl App f args -mkTyApp f args = foldl (\ e a -> App e (TyArg a)) f args -mkValApp f args = foldl (\ e a -> App e (is_Lit_or_Var a)) f args - -#ifndef DEBUG -is_Lit_or_Var a = a -#else -is_Lit_or_Var a - = if isValArg a then a else panic "CoreSyn.mkValApps:not LitArg or VarArg" -#endif - -isValArg (LitArg _) = True -- often used for sanity-checking -isValArg (VarArg _) = True -isValArg _ = False - -notValArg = not . isValArg -- exists only because it's a common use of isValArg - -numValArgs as = length [ a | a <- as, isValArg a ] -- again, convenience + go ids (Lam b e) | isId b = go (b:ids) e + go ids body = (reverse ids, body) \end{code} -\begin{code} -mkApp fun = mk_thing (mkGenApp fun) -mkCon con = mk_thing (Con con) -mkPrim op = mk_thing (Prim op) - -mk_thing :: ([GenCoreArg val_occ flexi] -> GenCoreExpr val_bdr val_occ flexi) - -> [GenType flexi] - -> [GenCoreArg val_occ flexi] - -> GenCoreExpr val_bdr val_occ flexi -mk_thing thing tys vals - = ASSERT( all isValArg vals ) - thing (map TyArg tys ++ vals) -\end{code} @collectArgs@ takes an application expression, returning the function and the arguments to which it is applied. \begin{code} -collectArgs :: GenCoreExpr val_bdr val_occ flexi - -> (GenCoreExpr val_bdr val_occ flexi, - [GenType flexi], - [GenCoreArg val_occ flexi]{-ValArgs-}) - +collectArgs :: Expr b -> (Expr b, [Arg b]) collectArgs expr - = valvars expr [] + = go expr [] where - valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc) - valvars fun vacc - = case (tyvars fun []) of { (expr, tacc) -> - (expr, tacc, vacc) } - - tyvars (App fun (TyArg t)) tacc = tyvars fun (t:tacc) - tyvars fun tacc = (expr, tacc) + go (App f a) as = go f (a:as) + go e as = (e, as) \end{code} +coreExprCc gets the cost centre enclosing an expression, if any. +It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e \begin{code} -initialTyArgs :: [GenCoreArg val_occ flexi] - -> ([GenType flexi], [GenCoreArg val_occ flexi]) -initialTyArgs (TyArg ty : args) = (ty:tys, args') - where - (tys, args') = initialTyArgs args -initialTyArgs other = ([],other) - -initialValArgs :: [GenCoreArg val_occ flexi] - -> ([GenCoreArg val_occ flexi], [GenCoreArg val_occ flexi]) -initialValArgs args = span isValArg args +coreExprCc :: Expr b -> CostCentre +coreExprCc (Note (SCC cc) e) = cc +coreExprCc (Note other_note e) = coreExprCc e +coreExprCc (Lam _ e) = coreExprCc e +coreExprCc other = noCostCentre \end{code} %************************************************************************ %* * -\subsection{The main @Core*@ instantiation of the @GenCore*@ types} +\subsection{Predicates} %* * %************************************************************************ \begin{code} -type CoreBinding = GenCoreBinding Id Id Unused -type CoreExpr = GenCoreExpr Id Id Unused -type CoreBinder = GenCoreBinder Id Unused -type CoreArg = GenCoreArg Id Unused +isValArg (Type _) = False +isValArg other = True + +isTypeArg (Type _) = True +isTypeArg other = False -type CoreCaseAlts = GenCoreCaseAlts Id Id Unused -type CoreCaseDefault = GenCoreCaseDefault Id Id Unused +valBndrCount :: [CoreBndr] -> Int +valBndrCount [] = 0 +valBndrCount (b : bs) | isId b = 1 + valBndrCount bs + | otherwise = valBndrCount bs + +valArgCount :: [Arg b] -> Int +valArgCount [] = 0 +valArgCount (Type _ : args) = valArgCount args +valArgCount (other : args) = 1 + valArgCount args \end{code} + %************************************************************************ %* * -\subsection{The @TaggedCore*@ instantiation of the @GenCore*@ types} +\subsection{Seq stuff} %* * %************************************************************************ -Binders are ``tagged'' with a \tr{t}: \begin{code} -type Tagged t = (Id, t) +seqExpr :: CoreExpr -> () +seqExpr (Var v) = v `seq` () +seqExpr (Con c as) = seqExprs as +seqExpr (App f a) = seqExpr f `seq` seqExpr a +seqExpr (Lam b e) = seqBndr b `seq` seqExpr e +seqExpr (Let b e) = seqBind b `seq` seqExpr e +seqExpr (Case e b as) = seqExpr e `seq` seqBndr b `seq` seqAlts as +seqExpr (Note n e) = seqNote n `seq` seqExpr e +seqExpr (Type t) = seqType t + +seqExprs [] = () +seqExprs (e:es) = seqExpr e `seq` seqExprs es + +seqNote (Coerce t1 t2) = seqType t1 `seq` seqType t2 +seqNote other = () + +seqBndr b = b `seq` () + +seqBndrs [] = () +seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs + +seqBind (NonRec b e) = seqBndr b `seq` seqExpr e +seqBind (Rec prs) = seqPairs prs + +seqPairs [] = () +seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs + +seqAlts [] = () +seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts + +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 +\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 (Con c as) = c `seq` exprsSize as +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 :: IdOrTyVar -> Int +varSize b | isTyVar b = 1 + | otherwise = seqType (idType b) `seq` + megaSeqIdInfo (idInfo b) `seq` + 1 -type TaggedCoreBinding t = GenCoreBinding (Tagged t) Id Unused -type TaggedCoreExpr t = GenCoreExpr (Tagged t) Id Unused -type TaggedCoreBinder t = GenCoreBinder (Tagged t) Unused -type TaggedCoreArg t = GenCoreArg Id Unused +varsSize = foldr ((+) . varSize) 0 -type TaggedCoreCaseAlts t = GenCoreCaseAlts (Tagged t) Id Unused -type TaggedCoreCaseDefault t = GenCoreCaseDefault (Tagged t) Id Unused +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} + %************************************************************************ %* * -\subsection{The @SimplifiableCore*@ instantiation of the @GenCore*@ types} +\subsection{Annotated core; annotation at every node in the tree} %* * %************************************************************************ -Binders are tagged with @BinderInfo@: \begin{code} -type Simplifiable = (Id, BinderInfo) +type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) + +data AnnExpr' bndr annot + = AnnVar Id + | AnnCon Con [AnnExpr bndr annot] + | AnnLam bndr (AnnExpr bndr annot) + | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) + | AnnCase (AnnExpr bndr annot) bndr [AnnAlt bndr annot] + | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) + | AnnNote Note (AnnExpr bndr annot) + | AnnType Type + +type AnnAlt bndr annot = (Con, [bndr], AnnExpr bndr annot) + +data AnnBind bndr annot + = AnnNonRec bndr (AnnExpr bndr annot) + | AnnRec [(bndr, AnnExpr bndr annot)] +\end{code} + +\begin{code} +deAnnotate :: AnnExpr bndr annot -> Expr bndr -type SimplifiableCoreBinding = GenCoreBinding Simplifiable Id Unused -type SimplifiableCoreExpr = GenCoreExpr Simplifiable Id Unused -type SimplifiableCoreBinder = GenCoreBinder Simplifiable Unused -type SimplifiableCoreArg = GenCoreArg Id Unused +deAnnotate (_, AnnType t) = Type t +deAnnotate (_, AnnVar v) = Var v +deAnnotate (_, AnnCon con args) = Con con (map deAnnotate args) +deAnnotate (_, AnnLam binder body)= Lam binder (deAnnotate body) +deAnnotate (_, AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) +deAnnotate (_, AnnNote note body) = Note note (deAnnotate body) -type SimplifiableCoreCaseAlts = GenCoreCaseAlts Simplifiable Id Unused -type SimplifiableCoreCaseDefault = GenCoreCaseDefault Simplifiable Id Unused +deAnnotate (_, AnnLet bind body) + = Let (deAnnBind bind) (deAnnotate body) + where + deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) + deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] + +deAnnotate (_, AnnCase scrut v alts) + = Case (deAnnotate scrut) v (map deAnnAlt alts) + where + deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) \end{code} +