module CoreSyn (
Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
- TaggedExpr, TaggedAlt, TaggedBind, TaggedArg,
+ TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
mkLets, mkLams,
mkApps, mkTyApps, mkValApps, mkVarApps,
isTyVar, isId,
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
- collectArgs, collectBindersIgnoringNotes,
+ collectArgs,
coreExprCc,
flattenBinds,
-- Annotated expressions
AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
- deAnnotate, deAnnotate', deAnnAlt,
+ deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
-- Core rules
CoreRules(..), -- Representation needed by friends
IdCoreRule,
RuleName,
emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
- isBuiltinRule
+ isBuiltinRule, ruleName
) where
#include "HsVersions.h"
import Var ( Var, Id, TyVar, isTyVar, isId )
import Type ( Type, mkTyVarTy, seqType )
import Literal ( Literal, mkMachInt )
-import DataCon ( DataCon, dataConId )
+import DataCon ( DataCon, dataConWorkId )
+import BasicTypes ( Activation )
import VarSet
+import FastString
import Outputable
\end{code}
| 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 *first*, if it occurs at all
+ -- Invariant: the list of alternatives is ALWAYS EXHAUSTIVE
+ -- Invariant: the DEFAULT case must be *first*, if it occurs at all
| Note Note (Expr b)
| Type Type -- This should only show up at the top
-- level of an Arg
| 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
\end{code}
\begin{code}
-type RuleName = FAST_STRING
+type RuleName = FastString
type IdCoreRule = (Id,CoreRule) -- Rules don't have their leading Id inside them
data CoreRule
= Rule RuleName
+ Activation -- When the rule is active
[CoreBndr] -- Forall'd variables
[CoreExpr] -- LHS args
CoreExpr -- RHS
| BuiltinRule -- Built-in rules are used for constant folding
- -- and suchlike. It has no free variables.
- ([CoreExpr] -> Maybe (RuleName, CoreExpr))
+ RuleName -- and suchlike. It has no free variables.
+ ([CoreExpr] -> Maybe CoreExpr)
+
+isBuiltinRule (BuiltinRule _ _) = True
+isBuiltinRule _ = False
-isBuiltinRule (BuiltinRule _) = True
-isBuiltinRule _ = False
+ruleName :: CoreRule -> RuleName
+ruleName (Rule n _ _ _ _) = n
+ruleName (BuiltinRule n _) = n
\end{code}
Binders are ``tagged'' with a \tr{t}:
\begin{code}
-type Tagged t = (CoreBndr, t)
+data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
+
+type TaggedBind t = Bind (TaggedBndr t)
+type TaggedExpr t = Expr (TaggedBndr t)
+type TaggedArg t = Arg (TaggedBndr t)
+type TaggedAlt t = Alt (TaggedBndr 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)
+instance Outputable b => Outputable (TaggedBndr b) where
+ ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
+
+instance Outputable b => OutputableBndr (TaggedBndr b) where
+ pprBndr _ b = ppr b -- Simple
\end{code}
mkLams :: [b] -> Expr b -> Expr b
mkLit lit = Lit lit
-mkConApp con args = mkApps (Var (dataConId con)) args
+mkConApp con args = mkApps (Var (dataConWorkId con)) args
mkLams binders body = foldr Lam body binders
mkLets binds body = foldr Let body binds
\begin{code}
collectBinders :: Expr b -> ([b], Expr b)
-collectBindersIgnoringNotes :: Expr b -> ([b], Expr b)
collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
collectValBinders :: CoreExpr -> ([Id], CoreExpr)
collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
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
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` ()
seqRules (Rules rules fvs) = seq_rules rules `seq` seqVarSet fvs
seq_rules [] = ()
-seq_rules (Rule fs bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules
-seq_rules (BuiltinRule _ : rules) = seq_rules rules
+seq_rules (Rule fs _ bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules
+seq_rules (BuiltinRule _ _ : rules) = seq_rules rules
\end{code}
deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
\end{code}
+\begin{code}
+collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
+collectAnnBndrs e
+ = collect [] e
+ where
+ collect bs (_, AnnLam b body) = collect (b:bs) body
+ collect bs body = (reverse bs, body)
+\end{code}