X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=201d86683457fbd8f6a1d8f0795151e80552281e;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=1599273d24f641993a4f31b97843783636b9cf25;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 1599273..201d866 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -1,549 +1,695 @@ % -% (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} -#include "HsVersions.h" - module CoreSyn ( - GenCoreBinding(..), GenCoreExpr(..), - GenCoreArg(..),GenCoreBinder(..), GenCoreCaseAlts(..), - GenCoreCaseDefault(..), - - bindersOf, pairsFromCoreBinds, rhssOfBind, - - mkGenApp, mkValApp, mkTyApp, mkUseApp, - mkApp, mkCon, mkPrim, - mkValLam, mkTyLam, mkUseLam, - mkLam, - digForLambdas, - - collectArgs, isValArg, - - 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(..) - - -- and to make the interface self-sufficient ... - + Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..), + CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, + TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), + + mkLets, mkLams, + mkApps, mkTyApps, mkValApps, mkVarApps, + mkLit, mkIntLitInt, mkIntLit, + mkConApp, + varToCoreExpr, + + isTyVar, isId, cmpAltCon, cmpAlt, ltAlt, + bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, + collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, + collectArgs, + coreExprCc, + flattenBinds, + + isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, + + -- Unfoldings + Unfolding(..), UnfoldingGuidance(..), -- Both abstract everywhere but in CoreUnfold.lhs + noUnfolding, evaldUnfolding, mkOtherCon, + unfoldingTemplate, maybeUnfoldingTemplate, otherCons, + isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding, + hasUnfolding, hasSomeUnfolding, neverUnfold, + + -- Seq stuff + seqExpr, seqExprs, seqUnfolding, + + -- Annotated expressions + AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, + deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs, + + -- Core rules + CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only + RuleName, seqRules, + isBuiltinRule, ruleName, isLocalRule, ruleIdName ) where -import Ubiq{-uitous-} - -import CostCentre ( showCostCentre, CostCentre ) -import Id ( idType ) -import Usage ( UVar(..) ) -import Util ( panic, assertPanic ) +#include "HsVersions.h" -isUnboxedDataType = panic "CoreSyn.isUnboxedDataType" ---eqId :: Id -> Id -> Bool -eqId = panic "CoreSyn.eqId" +import StaticFlags ( opt_RuntimeTypes ) +import CostCentre ( CostCentre, noCostCentre ) +import Var ( Var, Id, TyVar, isTyVar, isId ) +import Type ( Type, mkTyVarTy, seqType ) +import Name ( Name ) +import OccName ( OccName ) +import Literal ( Literal, mkMachInt ) +import DataCon ( DataCon, dataConWorkId, dataConTag ) +import BasicTypes ( Activation ) +import FastString +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 tyvar uvar - = NonRec val_bdr (GenCoreExpr val_bdr val_occ tyvar uvar) - | Rec [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)] +infixl 8 `App` -- App brackets to the left + +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 Type [Alt b] -- Binder gets bound to value of scrutinee + -- 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 + -- Invariant: The remaining cases are in order of increasing + -- tag (for DataAlts) + -- lit (for LitAlts) + -- This makes finding the relevant constructor easy, + -- and makes comparison easier too + | 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 + +data AltCon = DataAlt DataCon + | LitAlt Literal + | DEFAULT + deriving (Eq, Ord) + + +data Bind b = NonRec b (Expr b) + | Rec [(b, (Expr b))] + +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 + + | 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} -\begin{code} -bindersOf :: GenCoreBinding val_bdr val_occ tyvar uvar -> [val_bdr] +INVARIANTS: -pairsFromCoreBinds :: - [GenCoreBinding val_bdr val_occ tyvar uvar] -> - [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)] +* The RHS of a letrec, and the RHSs of all top-level lets, + must be of LIFTED type. -rhssOfBind :: GenCoreBinding val_bdr val_occ tyvar uvar -> [GenCoreExpr val_bdr val_occ tyvar uvar] +* 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] -bindersOf (NonRec binder _) = [binder] -bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] +* The argument of an App can be of any type. -pairsFromCoreBinds [] = [] -pairsFromCoreBinds ((NonRec b e) : bs) = (b,e) : pairsFromCoreBinds bs -pairsFromCoreBinds ((Rec pairs) : bs) = pairs ++ pairsFromCoreBinds bs +* 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. -rhssOfBind (NonRec _ rhs) = [rhs] -rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] -\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 tyvar uvar - = Var val_occ - | Lit Literal -- literal constants -\end{code} +The CoreRule type and its friends are dealt with mainly in CoreRules, +but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation. -@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. +A Rule is -\begin{code} - | Con Id [GenCoreArg val_occ tyvar uvar] - -- 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 tyvar uvar] - -- saturated primitive operation; - -- comment on Cons applies here, too. -\end{code} + "local" if the function it is a rule for is defined in the + same module as the rule itself. + + "orphan" if nothing on the LHS is defined in the same module + as the rule itself -Ye olde abstraction and application operators. \begin{code} - | Lam (GenCoreBinder val_bdr tyvar uvar) - (GenCoreExpr val_bdr val_occ tyvar uvar) +type RuleName = FastString - | App (GenCoreExpr val_bdr val_occ tyvar uvar) - (GenCoreArg val_occ tyvar uvar) -\end{code} +data CoreRule + = Rule { + ru_name :: RuleName, + ru_act :: Activation, -- When the rule is active + + -- Rough-matching stuff + -- see comments with InstEnv.Instance( is_cls, is_rough ) + ru_fn :: Name, -- Name of the Id at the head of this rule + ru_rough :: [Maybe Name], -- Name at the head of each argument + + -- Proper-matching stuff + -- see comments with InstEnv.Instance( is_tvs, is_tys ) + ru_bndrs :: [CoreBndr], -- Forall'd variables + ru_args :: [CoreExpr], -- LHS args + + -- And the right-hand side + ru_rhs :: CoreExpr, -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 tyvar uvar) - (GenCoreCaseAlts val_bdr val_occ tyvar uvar) -\end{code} + -- Locality + ru_local :: Bool, -- The fn at the head of the rule is + -- defined in the same module as the rule -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}). + -- Orphan-hood; see comments is InstEnv.Instance( is_orph ) + ru_orph :: Maybe OccName } -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 tyvar uvar) - (GenCoreExpr val_bdr val_occ tyvar uvar) - -- both recursive and non-. - -- The "GenCoreBinding" records that information -\end{code} + | BuiltinRule { -- Built-in rules are used for constant folding + ru_name :: RuleName, -- and suchlike. It has no free variables. + ru_fn :: Name, -- Name of the Id at + -- the head of this rule + ru_try :: [CoreExpr] -> Maybe CoreExpr } -For cost centre scc expressions we introduce a new core construct -@SCC@ so transforming passes have to deal with it explicitly. The -alternative of using a new PrimativeOp may result in a bad -transformations of which we are unaware. -\begin{code} - | SCC CostCentre -- label of scc - (GenCoreExpr val_bdr val_occ tyvar uvar) -- scc expression +isBuiltinRule (BuiltinRule {}) = True +isBuiltinRule _ = False + +ruleName :: CoreRule -> RuleName +ruleName = ru_name + +ruleIdName :: CoreRule -> Name +ruleIdName = ru_fn + +isLocalRule :: CoreRule -> Bool +isLocalRule = ru_local \end{code} %************************************************************************ %* * -\subsection{Core-constructing functions with checking} + Unfoldings %* * %************************************************************************ -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) +The @Unfolding@ type is declared here to avoid numerous loops, but it +should be abstract everywhere except in CoreUnfold.lhs \begin{code} -mkCoLetAny :: GenCoreBinding val_bdr val_occ tyvar uvar - -> GenCoreExpr val_bdr val_occ tyvar uvar - -> GenCoreExpr val_bdr val_occ tyvar uvar -mkCoLetsAny :: [GenCoreBinding val_bdr val_occ tyvar uvar] -> - GenCoreExpr val_bdr val_occ tyvar uvar -> - GenCoreExpr val_bdr val_occ tyvar uvar -mkCoLetrecAny :: [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)] - -> GenCoreExpr val_bdr val_occ tyvar uvar - -> GenCoreExpr val_bdr val_occ tyvar uvar - -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 - = case body of - Var binder2 | binder `eqId` binder2 - -> rhs -- hey, I have the rhs - other - -> Let bind body +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 -- exprIsHNF 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 +evaldUnfolding = OtherCon [] + +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} ---mkCoLetNoUnboxed :: --- GenCoreBinding val_bdr val_occ tyvar uvar -> --- GenCoreExpr val_bdr val_occ tyvar uvar -> --- GenCoreExpr val_bdr val_occ tyvar uvar - -mkCoLetNoUnboxed bind@(Rec binds) body - = mkCoLetrecNoUnboxed binds body -mkCoLetNoUnboxed bind@(NonRec binder rhs) body - = --ASSERT (not (isUnboxedDataType (idType binder))) - case body of - Var binder2 | binder `eqId` binder2 - -> rhs -- hey, I have the rhs - other - -> Let bind body - -mkCoLetsNoUnboxed [] expr = expr -mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds - ---mkCoLetrecNoUnboxed :: [(Id, CoreExpr)] -- bindings --- -> CoreExpr -- body --- -> CoreExpr -- result - -mkCoLetrecNoUnboxed [] body = body -mkCoLetrecNoUnboxed binds body - = ASSERT (all is_boxed_bind binds) - Let (Rec binds) body - where - is_boxed_bind (binder, rhs) - = (not . isUnboxedDataType . idType) binder +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} -\begin{code} ---mkCoLetUnboxedToCase :: --- GenCoreBinding val_bdr val_occ tyvar uvar -> --- GenCoreExpr val_bdr val_occ tyvar uvar -> --- GenCoreExpr val_bdr val_occ tyvar uvar - -mkCoLetUnboxedToCase bind@(Rec binds) body - = mkCoLetrecNoUnboxed binds body -mkCoLetUnboxedToCase bind@(NonRec binder rhs) body - = case body of - Var binder2 | binder `eqId` binder2 - -> rhs -- hey, I have the rhs - other - -> if (not (isUnboxedDataType (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 -\end{code} %************************************************************************ %* * -\subsection{Case alternatives in @GenCoreExpr@} +\subsection{The main data type} %* * %************************************************************************ -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 tyvar uvar - = AlgAlts [(Id, -- alts: data constructor, - [val_bdr], -- constructor's parameters, - GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs. - (GenCoreCaseDefault val_bdr val_occ tyvar uvar) - - | PrimAlts [(Literal, -- alts: unboxed literal, - GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs. - (GenCoreCaseDefault val_bdr val_occ tyvar uvar) - --- obvious things: if there are no alts in the list, then the default --- can't be NoDefault. - -data GenCoreCaseDefault val_bdr val_occ tyvar uvar - = NoDefault -- small con family: all - -- constructor accounted for - | BindDefault val_bdr -- form: var -> expr; - (GenCoreExpr val_bdr val_occ tyvar uvar) -- "val_bdr" may or may not - -- be used in RHS. +-- 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) + +cmpAlt :: Alt b -> Alt b -> Ordering +cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2 + +ltAlt :: Alt b -> Alt b -> Bool +ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False } + +cmpAltCon :: AltCon -> AltCon -> Ordering +-- Compares AltCons within a single list of alternatives +cmpAltCon DEFAULT DEFAULT = EQ +cmpAltCon DEFAULT con = LT + +cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2 +cmpAltCon (DataAlt _) DEFAULT = GT +cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2 +cmpAltCon (LitAlt _) DEFAULT = GT + +cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+> + ppr con1 <+> ppr con2 ) + LT \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{Useful synonyms} %* * %************************************************************************ +The common case + \begin{code} -data GenCoreBinder val_bdr tyvar uvar - = ValBinder val_bdr - | TyBinder tyvar - | UsageBinder uvar +type CoreBndr = Var +type CoreExpr = Expr CoreBndr +type CoreArg = Arg CoreBndr +type CoreBind = Bind CoreBndr +type CoreAlt = Alt CoreBndr \end{code} -Clump Lams together if possible. +Binders are ``tagged'' with a \tr{t}: \begin{code} -mkValLam :: [val_bdr] - -> GenCoreExpr val_bdr val_occ tyvar uvar - -> GenCoreExpr val_bdr val_occ tyvar uvar -mkTyLam :: [tyvar] - -> GenCoreExpr val_bdr val_occ tyvar uvar - -> GenCoreExpr val_bdr val_occ tyvar uvar -mkUseLam :: [uvar] - -> GenCoreExpr val_bdr val_occ tyvar uvar - -> GenCoreExpr val_bdr val_occ tyvar uvar - -mkValLam binders body = foldr (Lam . ValBinder) body binders -mkTyLam binders body = foldr (Lam . TyBinder) body binders -mkUseLam binders body = foldr (Lam . UsageBinder) body binders - -mkLam :: [tyvar] -> [val_bdr] -- ToDo: could add a [uvar] arg... - -> GenCoreExpr val_bdr val_occ tyvar uvar - -> GenCoreExpr val_bdr val_occ tyvar uvar - -mkLam tyvars valvars body - = mkTyLam tyvars (mkValLam valvars body) -\end{code} +data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder" -We often want to strip off leading lambdas before getting down to -business. @digForLambdas@ is your friend. +type TaggedBind t = Bind (TaggedBndr t) +type TaggedExpr t = Expr (TaggedBndr t) +type TaggedArg t = Arg (TaggedBndr t) +type TaggedAlt t = Alt (TaggedBndr t) -We expect (by convention) usage-, type-, and value- lambdas in that -order. +instance Outputable b => Outputable (TaggedBndr b) where + ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>' -\begin{code} -digForLambdas :: - GenCoreExpr val_bdr val_occ tyvar uvar -> - ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar) - -digForLambdas (Lam (UsageBinder u) body) - = let - (uvars, tyvars, args, final_body) = digForLambdas body - in - (u:uvars, tyvars, args, final_body) - -digForLambdas other - = let - (tyvars, args, body) = dig_for_tyvars other - in - ([], tyvars, args, body) - where - dig_for_tyvars (Lam (TyBinder tv) body) - = let - (tyvars, args, body2) = dig_for_tyvars body - in - (tv : tyvars, args, body2) - - dig_for_tyvars body - = ASSERT(not (usage_lambda body)) - let - (args, body2) = dig_for_valvars body - in - ([], args, body2) - - --------------------------------------- - dig_for_valvars (Lam (ValBinder v) body) - = let - (args, body2) = dig_for_valvars body - in - (v : args, body2) - - dig_for_valvars body - = ASSERT(not (usage_lambda body)) - ASSERT(not (tyvar_lambda body)) - ([], body) - - --------------------------------------- - usage_lambda (Lam (UsageBinder _) _) = True - usage_lambda _ = False - - tyvar_lambda (Lam (TyBinder _) _) = True - tyvar_lambda _ = False +instance Outputable b => OutputableBndr (TaggedBndr b) where + pprBndr _ b = ppr b -- Simple \end{code} + %************************************************************************ %* * -\subsection{Core arguments (atoms)} +\subsection{Core-constructing functions with checking} %* * %************************************************************************ \begin{code} -data GenCoreArg val_occ tyvar uvar - = LitArg Literal - | VarArg val_occ - | TyArg (GenType tyvar uvar) - | UsageArg (GenUsage uvar) +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 (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)) + +varToCoreExpr :: CoreBndr -> Expr b +varToCoreExpr v | isId v = Var v + | otherwise = Type (mkTyVarTy v) \end{code} -General and specific forms: + +%************************************************************************ +%* * +\subsection{Simple access functions} +%* * +%************************************************************************ + \begin{code} -mkGenApp :: GenCoreExpr val_bdr val_occ tyvar uvar - -> [GenCoreArg val_occ tyvar uvar] - -> GenCoreExpr val_bdr val_occ tyvar uvar -mkTyApp :: GenCoreExpr val_bdr val_occ tyvar uvar - -> [GenType tyvar uvar] - -> GenCoreExpr val_bdr val_occ tyvar uvar -mkUseApp :: GenCoreExpr val_bdr val_occ tyvar uvar - -> [GenUsage uvar] - -> GenCoreExpr val_bdr val_occ tyvar uvar -mkValApp :: GenCoreExpr val_bdr val_occ tyvar uvar - -> [GenCoreArg val_occ tyvar uvar] -- but we ASSERT they are LitArg or VarArg - -> GenCoreExpr val_bdr val_occ tyvar uvar - -mkGenApp f args = foldl App f args -mkTyApp f args = foldl (\ e a -> App e (TyArg a)) f args -mkUseApp f args = foldl (\ e a -> App e (UsageArg 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 +bindersOf :: Bind b -> [b] +bindersOf (NonRec binder _) = [binder] +bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] + +bindersOfBinds :: [Bind b] -> [b] +bindersOfBinds binds = foldr ((++) . bindersOf) [] binds + +rhssOfBind :: Bind b -> [Expr b] +rhssOfBind (NonRec _ rhs) = [rhs] +rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] + +rhssOfAlts :: [Alt b] -> [Expr b] +rhssOfAlts alts = [e | (_,_,e) <- alts] + +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) type-, and value- lambdas in that +order. + \begin{code} -mkApp fun = mk_thing (mkGenApp fun) -mkCon con = mk_thing (Con con) -mkPrim op = mk_thing (Prim op) +collectBinders :: Expr b -> ([b], Expr b) +collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) +collectValBinders :: CoreExpr -> ([Id], CoreExpr) +collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) + +collectBinders expr + = go [] expr + where + go bs (Lam b e) = go (b:bs) e + go bs e = (reverse bs, e) + +collectTyAndValBinders expr + = (tvs, ids, body) + where + (tvs, body1) = collectTyBinders expr + (ids, body) = collectValBinders body1 -mk_thing thing uses tys vals - = thing (map UsageArg uses ++ map TyArg tys ++ map is_Lit_or_Var vals) +collectTyBinders expr + = go [] expr + where + go tvs (Lam b e) | isTyVar b = go (b:tvs) e + go tvs e = (reverse tvs, e) + +collectValBinders expr + = go [] expr + where + go ids (Lam b e) | isId b = go (b:ids) e + go ids body = (reverse ids, body) \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 tyvar uvar - -> (GenCoreExpr val_bdr val_occ tyvar uvar, - [GenCoreArg val_occ tyvar uvar]) - +collectArgs :: Expr b -> (Expr b, [Arg b]) collectArgs expr - = collect expr [] + = go expr [] where - collect (App fun arg) args = collect fun (arg : args) - collect fun args = (fun, args) + 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} +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} %* * %************************************************************************ +@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} -type CoreBinding = GenCoreBinding Id Id TyVar UVar -type CoreExpr = GenCoreExpr Id Id TyVar UVar -type CoreBinder = GenCoreBinder Id TyVar UVar -type CoreArg = GenCoreArg Id TyVar UVar +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 + +isTypeArg (Type _) = True +isTypeArg other = False + +valBndrCount :: [CoreBndr] -> Int +valBndrCount [] = 0 +valBndrCount (b : bs) | isId b = 1 + valBndrCount bs + | otherwise = valBndrCount bs -type CoreCaseAlts = GenCoreCaseAlts Id Id TyVar UVar -type CoreCaseDefault = GenCoreCaseDefault Id Id TyVar UVar +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 +-- gaw 2004 +seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `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 (CoreNote s) = s `seq` () +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 [] = () +seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) + = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules +seqRules (BuiltinRule {} : rules) = seqRules rules +\end{code} -type TaggedCoreBinding t = GenCoreBinding (Tagged t) Id TyVar UVar -type TaggedCoreExpr t = GenCoreExpr (Tagged t) Id TyVar UVar -type TaggedCoreBinder t = GenCoreBinder (Tagged t) TyVar UVar -type TaggedCoreArg t = GenCoreArg Id TyVar UVar -type TaggedCoreCaseAlts t = GenCoreCaseAlts (Tagged t) Id TyVar UVar -type TaggedCoreCaseDefault t = GenCoreCaseDefault (Tagged t) Id TyVar UVar -\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) +-- gaw 2004 + | AnnCase (AnnExpr bndr annot) bndr Type [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} + +\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] + +-- gaw 2004 +deAnnotate' (AnnCase scrut v t alts) + = Case (deAnnotate scrut) v t (map deAnnAlt alts) -type SimplifiableCoreBinding = GenCoreBinding Simplifiable Id TyVar UVar -type SimplifiableCoreExpr = GenCoreExpr Simplifiable Id TyVar UVar -type SimplifiableCoreBinder = GenCoreBinder Simplifiable TyVar UVar -type SimplifiableCoreArg = GenCoreArg Id TyVar UVar +deAnnAlt :: AnnAlt bndr annot -> Alt bndr +deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) +\end{code} -type SimplifiableCoreCaseAlts = GenCoreCaseAlts Simplifiable Id TyVar UVar -type SimplifiableCoreCaseDefault = GenCoreCaseDefault Simplifiable Id TyVar UVar +\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}