X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=a8ef5bd7b6cc2c9d10bcbe27a345df975b182e47;hb=89300e499da98bf95bcc18d895ac4369e761819a;hp=4d8284d4d364b75dca92b130b7bbe14376e4f724;hpb=b4255f2c320f852d7dfb0afc0bc9f64765aece0c;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 4d8284d..a8ef5bd 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -1,185 +1,113 @@ % -% (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, - collectBinders, isValBinder, notValBinder, - - collectArgs, 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(..) - - -- and to make the interface self-sufficient ... + Expr(..), Alt, Bind(..), Arg(..), Note(..), + CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, + TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, - ) where + mkLets, mkLetBinds, mkLams, + mkApps, mkTyApps, mkValApps, + mkLit, mkStringLit, mkConApp, mkPrimApp, mkNote, mkNilExpr, + bindNonRec, mkIfThenElse, varToCoreExpr, -import Ubiq{-uitous-} + bindersOf, rhssOfBind, rhssOfAlts, isDeadBinder, isTyVar, isId, + collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, + collectArgs, + coreExprCc, --- ToDo:rm: ---import PprCore ( GenCoreExpr{-instance-} ) ---import PprStyle ( PprStyle(..) ) + isValArg, isTypeArg, valArgCount, -import CostCentre ( showCostCentre, CostCentre ) -import Id ( idType, GenId{-instance Eq-} ) -import Type ( isUnboxedType ) -import Usage ( UVar(..) ) -import Util ( panic, assertPanic {-pprTrace:ToDo:rm-} ) + -- Annotated expressions + AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate + ) where + +#include "HsVersions.h" + +import TysWiredIn ( boolTy, stringTy, nilDataCon ) +import CostCentre ( CostCentre, isDupdCC, noCostCentre ) +import Var ( Var, Id, TyVar, IdOrTyVar, isTyVar, isId, idType ) +import Id ( mkWildId, getInlinePragma ) +import Type ( Type, mkTyVarTy, isUnLiftedType ) +import IdInfo ( InlinePragInfo(..) ) +import Const ( Con(..), DataCon, Literal(NoRepStr), PrimOp ) +import TysWiredIn ( trueDataCon, falseDataCon ) +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)] +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 + + | 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 \end{code} -\begin{code} -bindersOf :: GenCoreBinding val_bdr val_occ tyvar uvar -> [val_bdr] - -pairsFromCoreBinds :: - [GenCoreBinding val_bdr val_occ tyvar uvar] -> - [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)] - -rhssOfBind :: GenCoreBinding val_bdr val_occ tyvar uvar -> [GenCoreExpr val_bdr val_occ tyvar uvar] - -bindersOf (NonRec binder _) = [binder] -bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] - -pairsFromCoreBinds [] = [] -pairsFromCoreBinds ((NonRec b e) : bs) = (b,e) : pairsFromCoreBinds bs -pairsFromCoreBinds ((Rec pairs) : bs) = pairs ++ pairsFromCoreBinds bs - -rhssOfBind (NonRec _ rhs) = [rhs] -rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] -\end{code} %************************************************************************ %* * -\subsection[GenCoreExpr]{Core expressions: @GenCoreExpr@} +\subsection{Useful synonyms} %* * %************************************************************************ -@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} - -@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. +The common case \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. +type CoreBndr = IdOrTyVar +type CoreExpr = Expr CoreBndr +type CoreArg = Arg CoreBndr +type CoreBind = Bind CoreBndr +type CoreAlt = Alt CoreBndr +type CoreNote = Note \end{code} -Ye olde abstraction and application operators. -\begin{code} - | Lam (GenCoreBinder val_bdr tyvar uvar) - (GenCoreExpr val_bdr val_occ tyvar uvar) - - | App (GenCoreExpr val_bdr val_occ tyvar uvar) - (GenCoreArg val_occ tyvar uvar) -\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 tyvar uvar) - (GenCoreCaseAlts val_bdr val_occ tyvar uvar) -\end{code} - -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}). +Binders are ``tagged'' with a \tr{t}: -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} +type Tagged t = (CoreBndr, t) -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 +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} @@ -189,379 +117,242 @@ transformations of which we are unaware. %* * %************************************************************************ -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 tyvar uvar - -> GenCoreExpr Id Id tyvar uvar - -> GenCoreExpr Id Id tyvar uvar -mkCoLetsAny :: [GenCoreBinding Id Id tyvar uvar] -> - GenCoreExpr Id Id tyvar uvar -> - GenCoreExpr Id Id 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 == binder2 - -> rhs -- hey, I have the rhs - other - -> Let bind body +mkApps :: Expr b -> [Arg b] -> Expr b +mkTyApps :: Expr b -> [Type] -> Expr b +mkValApps :: Expr b -> [Expr b] -> 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 + +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 + +mkNilExpr :: Type -> CoreExpr +mkNilExpr ty = Con (DataCon nilDataCon) [Type ty] + +varToCoreExpr :: CoreBndr -> CoreExpr +varToCoreExpr v | isId v = Var v + | otherwise = Type (mkTyVarTy v) \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 (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 :: [(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 . isUnboxedType . idType) binder +mkLams :: [b] -> Expr b -> Expr b +mkLams binders body = foldr Lam body binders \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 == 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 + +mkLetBinds :: [CoreBind] -> CoreExpr -> CoreExpr +-- mkLetBinds is like mkLets, but it uses bindNonRec to +-- make a case binding for unlifted things +mkLetBinds [] body = body +mkLetBinds (NonRec b r : binds) body = bindNonRec b r (mkLetBinds binds body) +mkLetBinds (bind : binds) body = Let bind (mkLetBinds binds body) + +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 +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 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. -\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 -rhssOfDeflt NoDefault = [] -rhssOfDeflt (BindDefault _ rhs) = [rhs] +mkNote note@(SCC cc1) expr@(Lam x e) -- Move _scc_ inside lambda + = Lam x (mkNote note e) + +-- Slide InlineCall in around the function +mkNote InlineCall (App f a) = App (mkNote InlineCall f) a +mkNote InlineCall (Var v) = Note InlineCall (Var v) +mkNote InlineCall expr = expr + +mkNote note expr = Note note expr \end{code} %************************************************************************ %* * -\subsection{Core binders} +\subsection{Simple access functions} %* * %************************************************************************ \begin{code} -data GenCoreBinder val_bdr tyvar uvar - = ValBinder val_bdr - | TyBinder tyvar - | UsageBinder uvar - -isValBinder (ValBinder _) = True -isValBinder _ = False +bindersOf :: Bind b -> [b] +bindersOf (NonRec binder _) = [binder] +bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] -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 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) +isDeadBinder :: CoreBndr -> Bool +isDeadBinder bndr | isId bndr = case getInlinePragma bndr of + IAmDead -> True + other -> False + | otherwise = False -- TyVars count as not dead \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 tyvar uvar -> - ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar) +collectBinders :: Expr b -> ([b], Expr b) +collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) +collectValBinders :: CoreExpr -> ([Id], CoreExpr) +collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) -collectBinders expr - = usages expr [] +collectTyAndValBinders expr + = (tvs, ids, body) where - usages (Lam (UsageBinder u) body) uacc = usages body (u:uacc) - usages other uacc - = case (tyvars other []) of { (tacc, vacc, expr) -> - (reverse uacc, tacc, vacc, expr) } - - tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc) - tyvars other tacc - = ASSERT(not (usage_lambda other)) - case (valvars other []) of { (vacc, expr) -> - (reverse tacc, vacc, expr) } - - valvars (Lam (ValBinder v) body) vacc = valvars body (v:vacc) - valvars other vacc - = ASSERT(not (usage_lambda other)) - ASSERT(not (tyvar_lambda other)) - (reverse vacc, other) - - --------------------------------------- - usage_lambda (Lam (UsageBinder _) _) = True - usage_lambda _ = False - - tyvar_lambda (Lam (TyBinder _) _) = True - tyvar_lambda _ = False -\end{code} + (tvs, body1) = collectTyBinders expr + (ids, body) = collectValBinders body1 -%************************************************************************ -%* * -\subsection{Core arguments (atoms)} -%* * -%************************************************************************ +collectBinders expr + = go [] expr + where + go tvs (Lam b e) = go (b:tvs) e + go tvs e = (reverse tvs, e) -\begin{code} -data GenCoreArg val_occ tyvar uvar - = LitArg Literal - | VarArg val_occ - | TyArg (GenType tyvar uvar) - | UsageArg (GenUsage uvar) -\end{code} +collectTyBinders expr + = go [] expr + where + go tvs (Lam b e) | isTyVar b = go (b:tvs) e + go tvs e = (reverse tvs, e) -General and specific forms: -\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 - -notValArg = not . isValArg -- exists only because it's a common use of isValArg - -numValArgs as = length [ a | a <- as, isValArg a ] -- again, convenience +collectValBinders expr + = go [] expr + where + 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 thing uses tys vals - = thing (map UsageArg uses ++ map TyArg tys ++ map is_Lit_or_Var 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 tyvar uvar - -> (GenCoreExpr val_bdr val_occ tyvar uvar, - [GenUsage uvar], - [GenType tyvar uvar], - [GenCoreArg val_occ tyvar uvar]{-ValArgs-}) - +collectArgs :: Expr b -> (Expr b, [Arg b]) collectArgs expr - = usages expr [] + = go expr [] where - usages (App fun (UsageArg u)) uacc = usages fun (u:uacc) - usages fun uacc - = case (tyvars fun []) of { (expr, tacc, vacc) -> - (expr, uacc, tacc, vacc) } - - tyvars (App fun (TyArg t)) tacc = tyvars fun (t:tacc) - tyvars fun tacc - = ASSERT(not (usage_app fun)) - case (valvars fun []) of { (expr, vacc) -> - (expr, tacc, vacc) } - - valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc) - valvars fun vacc - = --ASSERT(not (usage_app fun)) - --ASSERT(not (ty_app fun)) - (if (usage_app fun || ty_app fun) then trace "CoreSyn:valvars" {-(ppr PprDebug fun)-} else id) $ - (fun, vacc) - - --------------------------------------- - usage_app (App _ (UsageArg _)) = True - usage_app _ = False - - ty_app (App _ (TyArg _)) = True - ty_app _ = False + go (App f a) as = go f (a:as) + go e as = (e, as) \end{code} -%************************************************************************ -%* * -\subsection{The main @Core*@ instantiation of the @GenCore*@ types} -%* * -%************************************************************************ +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} -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 - -type CoreCaseAlts = GenCoreCaseAlts Id Id TyVar UVar -type CoreCaseDefault = GenCoreCaseDefault Id Id TyVar UVar +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 @TaggedCore*@ instantiation of the @GenCore*@ types} +\subsection{Predicates} %* * %************************************************************************ -Binders are ``tagged'' with a \tr{t}: \begin{code} -type Tagged t = (Id, t) +isValArg (Type _) = False +isValArg other = True -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 +isTypeArg (Type _) = True +isTypeArg other = False -type TaggedCoreCaseAlts t = GenCoreCaseAlts (Tagged t) Id TyVar UVar -type TaggedCoreCaseDefault t = GenCoreCaseDefault (Tagged t) Id TyVar UVar +valArgCount :: [Arg b] -> Int +valArgCount [] = 0 +valArgCount (Type _ : args) = valArgCount args +valArgCount (other : args) = 1 + valArgCount args \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 + +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 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 +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 TyVar UVar -type SimplifiableCoreCaseDefault = GenCoreCaseDefault Simplifiable Id TyVar UVar +deAnnotate (_, AnnCase scrut v alts) + = Case (deAnnotate scrut) v (map deAnnAlt alts) + where + deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) \end{code} +