X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=60a7db0cc057364ec348ac8ea4829e23243e8cdc;hb=6eca2acf184d4911123193757bdd38e53caa3467;hp=c76e75f17511bab24aef0f13bc1adb94fe4a1495;hpb=d4f1ad72f0c3c7a1f4747336c86f7d0a179e68cd;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index c76e75f..60a7db0 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -1,556 +1,573 @@ % -% (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(..), AltCon(..), Arg, Note(..), + CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, + TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, + + mkLets, mkLams, + mkApps, mkTyApps, mkValApps, mkVarApps, + mkLit, mkIntLitInt, mkIntLit, + mkConApp, + varToCoreExpr, + + bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isTyVar, isId, + collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, + collectArgs, collectBindersIgnoringNotes, + coreExprCc, + flattenBinds, + + isValArg, isTypeArg, valArgCount, valBndrCount, + + -- Unfoldings + Unfolding(..), UnfoldingGuidance(..), -- Both abstract everywhere but in CoreUnfold.lhs + noUnfolding, mkOtherCon, + unfoldingTemplate, maybeUnfoldingTemplate, otherCons, + isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding, + hasUnfolding, hasSomeUnfolding, + + -- Seq stuff + seqRules, seqExpr, seqExprs, seqUnfolding, + + -- Annotated expressions + AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate, deAnnotate', + + -- Core rules + CoreRules(..), -- Representation needed by friends + CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only + RuleName, + emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules, + isBuiltinRule ) 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 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 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} +infixl 8 `App` -- App brackets to the left -\begin{code} -bindersOf :: GenCoreBinding val_bdr val_occ flexi -> [val_bdr] +data Expr b -- "b" for the type of binders, + = Var Id + | Lit Literal + | 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 -pairsFromCoreBinds :: - [GenCoreBinding val_bdr val_occ flexi] -> - [(val_bdr, GenCoreExpr val_bdr val_occ flexi)] +type Arg b = Expr b -- Can be a Type -rhssOfBind :: GenCoreBinding val_bdr val_occ flexi -> [GenCoreExpr val_bdr val_occ flexi] +type Alt b = (AltCon, [b], Expr b) -- (DEFAULT, [], rhs) is the default alternative -bindersOf (NonRec binder _) = [binder] -bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] +data AltCon = DataAlt DataCon + | LitAlt Literal + | DEFAULT + deriving (Eq, Ord) -pairsFromCoreBinds [] = [] -pairsFromCoreBinds ((NonRec b e) : bs) = (b,e) : pairsFromCoreBinds bs -pairsFromCoreBinds ((Rec pairs) : bs) = pairs ++ pairsFromCoreBinds bs +data Bind b = NonRec b (Expr b) + | Rec [(b, (Expr b))] -rhssOfBind (NonRec _ rhs) = [rhs] -rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] +data Note + = SCC CostCentre + + | Coerce + Type -- The to-type: type of whole coerce expression + Type -- The from-type: type of enclosed expression + + | InlineCall -- Instructs simplifier to inline + -- the enclosed call + + | 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) \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@. +The CoreRule type and its friends are dealt with mainly in CoreRules, +but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation. + \begin{code} -data GenCoreExpr val_bdr val_occ flexi - = Var val_occ - | Lit Literal -- literal constants -\end{code} +data CoreRules + = Rules [CoreRule] + VarSet -- Locally-defined free vars of RHSs -@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. +emptyCoreRules :: CoreRules +emptyCoreRules = Rules [] emptyVarSet -\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} +isEmptyCoreRules :: CoreRules -> Bool +isEmptyCoreRules (Rules rs _) = null rs -Ye olde abstraction and application operators. -\begin{code} - | Lam (GenCoreBinder val_bdr flexi) - (GenCoreExpr val_bdr val_occ flexi) +rulesRhsFreeVars :: CoreRules -> VarSet +rulesRhsFreeVars (Rules _ fvs) = fvs - | App (GenCoreExpr val_bdr val_occ flexi) - (GenCoreArg val_occ flexi) +rulesRules :: CoreRules -> [CoreRule] +rulesRules (Rules rules _) = rules \end{code} -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} +type RuleName = FAST_STRING -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}). +data CoreRule + = Rule RuleName + [CoreBndr] -- Forall'd variables + [CoreExpr] -- LHS args + CoreExpr -- RHS -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} + | BuiltinRule -- Built-in rules are used for constant folding + -- and suchlike. It has no free variables. + ([CoreExpr] -> Maybe (RuleName, CoreExpr)) -A @Note@ annotates a @CoreExpr@ with useful information -of some kind. -\begin{code} - | Note (CoreNote flexi) - (GenCoreExpr val_bdr val_occ flexi) +isBuiltinRule (BuiltinRule _) = True +isBuiltinRule _ = False \end{code} %************************************************************************ %* * -\subsection{Core-notes} +\subsection{@Unfolding@ type} %* * %************************************************************************ -\begin{code} -data CoreNote flexi - = SCC - CostCentre - - | Coerce - (GenType flexi) -- The to-type: type of whole coerce expression - (GenType flexi) -- The from-type: type of enclosed expression +The @Unfolding@ type is declared here to avoid numerous loops, but it +should be abstract everywhere except in CoreUnfold.lhs - | InlineCall -- Instructs simplifier to inline - -- the enclosed call +\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 +\end{code} %************************************************************************ %* * -\subsection{Core-constructing functions with checking} +\subsection{The main data type} %* * %************************************************************************ -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 +-- The Ord is needed for the FiniteMap used in the lookForConstructor +-- in SimplEnv. If you declared that lookForConstructor *ignores* +-- constructor-applications with LitArg args, then you could get +-- rid of this Ord. + +instance Outputable AltCon where + ppr (DataAlt dc) = ppr dc + ppr (LitAlt lit) = ppr lit + ppr DEFAULT = ptext SLIT("__DEFAULT") + +instance Show AltCon where + showsPrec p con = showsPrecSDoc p (ppr con) +\end{code} -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 +%************************************************************************ +%* * +\subsection{Useful synonyms} +%* * +%************************************************************************ -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 -\end{code} +The common case \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 +type CoreBndr = Var +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} -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 +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} + %************************************************************************ %* * -\subsection{Case alternatives in @GenCoreExpr@} +\subsection{Core-constructing functions with checking} %* * %************************************************************************ -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} - \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. +mkApps :: Expr b -> [Arg b] -> Expr b +mkTyApps :: Expr b -> [Type] -> Expr b +mkValApps :: Expr b -> [Expr b] -> Expr b +mkVarApps :: Expr b -> [Var] -> Expr b + +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 +mkIntLit :: Integer -> Expr b +mkIntLitInt :: Int -> Expr b +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 + +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)) + +varToCoreExpr :: CoreBndr -> Expr b +varToCoreExpr v | isId v = Var v + | otherwise = Type (mkTyVarTy v) \end{code} -\begin{code} -rhssOfAlts (AlgAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,_,rhs) <- alts] -rhssOfAlts (PrimAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,rhs) <- alts] - -rhssOfDeflt NoDefault = [] -rhssOfDeflt (BindDefault _ rhs) = [rhs] -\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) +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) + go ids (Lam b e) | isId b = go (b:ids) e + go ids body = (reverse ids, body) \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 -\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 = (fun, tacc) - -- WAS: tyvars fun tacc = (expr, tacc) - -- This doesn't look right (i.e., Plain Wrong), - -- collectArgs should return the the function and - -- not the whole expr. -- Laszlo 8/98 - + 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 (Lit lit) = lit `seq` () +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` () -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 +seqBndrs [] = () +seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs -type TaggedCoreCaseAlts t = GenCoreCaseAlts (Tagged t) Id Unused -type TaggedCoreCaseDefault t = GenCoreCaseDefault (Tagged t) Id Unused +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 +seq_rules (BuiltinRule _ : rules) = seq_rules rules \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 + | AnnLit Literal + | 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 = (AltCon, [bndr], AnnExpr bndr annot) + +data AnnBind bndr annot + = AnnNonRec bndr (AnnExpr bndr annot) + | AnnRec [(bndr, AnnExpr bndr annot)] +\end{code} -type SimplifiableCoreBinding = GenCoreBinding Simplifiable Id Unused -type SimplifiableCoreExpr = GenCoreExpr Simplifiable Id Unused -type SimplifiableCoreBinder = GenCoreBinder Simplifiable Unused -type SimplifiableCoreArg = GenCoreArg Id Unused +\begin{code} +deAnnotate :: AnnExpr bndr annot -> Expr bndr +deAnnotate (_, e) = deAnnotate' e + +deAnnotate' (AnnType t) = Type t +deAnnotate' (AnnVar v) = Var v +deAnnotate' (AnnLit lit) = Lit lit +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) + +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] -type SimplifiableCoreCaseAlts = GenCoreCaseAlts Simplifiable Id Unused -type SimplifiableCoreCaseDefault = GenCoreCaseDefault Simplifiable Id Unused +deAnnotate' (AnnCase scrut v alts) + = Case (deAnnotate scrut) v (map deAnnAlt alts) + where + deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) \end{code} +