%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[CoreSyn]{A data type for the Haskell compiler midsection}
+
+CoreSyn: A data type for the Haskell compiler midsection
\begin{code}
module CoreSyn (
-- Core rules
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
- RuleName, seqRules,
+ RuleName, seqRules, ruleArity,
isBuiltinRule, ruleName, isLocalRule, ruleIdName
) where
#include "HsVersions.h"
-import StaticFlags ( opt_RuntimeTypes )
-import CostCentre ( CostCentre, noCostCentre )
-import Var ( Var, Id, TyVar, isTyVar, isId )
-import Type ( Type, mkTyVarTy, seqType )
-import Coercion ( Coercion )
-import Name ( Name )
-import OccName ( OccName )
-import Literal ( Literal, mkMachInt )
-import DataCon ( DataCon, dataConWorkId, dataConTag )
-import BasicTypes ( Activation )
+import StaticFlags
+import CostCentre
+import Var
+import Type
+import Coercion
+import Name
+import Literal
+import DataCon
+import BasicTypes
import FastString
import Outputable
+import Util
infixl 4 `mkApps`, `mkValApps`, `mkTyApps`, `mkVarApps`
-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
data Expr b -- "b" for the type of binders,
= Var Id
| Lit Literal
- | App (Expr b) (Arg b)
+ | App (Expr b) (Arg b) -- See Note [CoreSyn let/app invariant]
| Lam b (Expr b)
- | Let (Bind b) (Expr b)
+ | Let (Bind b) (Expr b) -- See [CoreSyn let/app invariant],
+ -- and [CoreSyn letrec invariant]
| 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
+ -- See Note [CoreSyn case invariants]
| Cast (Expr b) Coercion
| 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 Bind b = NonRec b (Expr b)
| Rec [(b, (Expr b))]
+\end{code}
+
+-------------------------- CoreSyn INVARIANTS ---------------------------
+
+Note [CoreSyn top-level invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* The RHSs of all top-level lets must be of LIFTED type.
+
+Note [CoreSyn letrec invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* The RHS of a letrec must be of LIFTED type.
+
+Note [CoreSyn let/app invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* The RHS of a non-recursive let, *and* the argument of an App,
+ 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]
+This is intially enforced by DsUtils.mkDsLet and mkDsApp
+
+Note [CoreSyn case invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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
+
+Invariant: The list of alternatives is ALWAYS EXHAUSTIVE,
+ meaning that it covers all cases that can occur
+
+ An "exhaustive" 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.
+
+
+Note [CoreSyn let goal]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* 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.
+
+\begin{code}
data Note
= SCC CostCentre
-- should inline f even inside lambdas. In effect, we should trust the programmer.
\end{code}
-INVARIANTS:
-
-* The RHS of a letrec, and the RHSs of all top-level lets,
- must be of LIFTED type.
-
-* 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]
-
-* The argument of an App can be of any type.
-
-* 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.
-
%************************************************************************
%* *
ru_rhs :: CoreExpr,
-- Locality
- ru_local :: Bool, -- The fn at the head of the rule is
+ ru_local :: Bool -- The fn at the head of the rule is
-- defined in the same module as the rule
-
- -- Orphan-hood; see comments is InstEnv.Instance( is_orph )
- ru_orph :: Maybe OccName }
+ -- and is not an implicit Id (like a record sel
+ -- class op, or data con)
+ -- NB: ru_local is *not* used to decide orphan-hood
+ -- c.g. MkIface.coreRuleToIfaceRule
+ }
| 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_nargs :: Int, -- Number of args that ru_try expects,
+ -- including type args
ru_try :: [CoreExpr] -> Maybe CoreExpr }
+ -- This function does the rewrite. It given too many
+ -- arguments, it simply discards them; the returned CoreExpr
+ -- is just the rewrite of ru_fn applied to the first ru_nargs args
+ -- See Note [Extra args in rule matching] in Rules.lhs
+isBuiltinRule :: CoreRule -> Bool
isBuiltinRule (BuiltinRule {}) = True
isBuiltinRule _ = False
+ruleArity :: CoreRule -> Int
+ruleArity (BuiltinRule {ru_nargs = n}) = n
+ruleArity (Rule {ru_args = args}) = length args
+
ruleName :: CoreRule -> RuleName
ruleName = ru_name
-- a context (case (thing args) of ...),
-- (where there are the right number of arguments.)
+noUnfolding, evaldUnfolding :: Unfolding
noUnfolding = NoUnfolding
evaldUnfolding = OtherCon []
+mkOtherCon :: [AltCon] -> Unfolding
mkOtherCon = OtherCon
seqUnfolding :: Unfolding -> ()
seqUnfolding (CoreUnfolding e top b1 b2 g)
= seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
-seqUnfolding other = ()
+seqUnfolding _ = ()
+seqGuidance :: UnfoldingGuidance -> ()
seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
-seqGuidance other = ()
+seqGuidance _ = ()
\end{code}
\begin{code}
unfoldingTemplate :: Unfolding -> CoreExpr
unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
unfoldingTemplate (CompulsoryUnfolding expr) = expr
-unfoldingTemplate other = panic "getUnfoldingTemplate"
+unfoldingTemplate _ = panic "getUnfoldingTemplate"
maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
-maybeUnfoldingTemplate other = Nothing
+maybeUnfoldingTemplate _ = Nothing
otherCons :: Unfolding -> [AltCon]
otherCons (OtherCon cons) = cons
-otherCons other = []
+otherCons _ = []
isValueUnfolding :: Unfolding -> Bool
-- Returns False for OtherCon
isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
-isValueUnfolding other = False
+isValueUnfolding _ = False
isEvaldUnfolding :: Unfolding -> Bool
-- Returns True for OtherCon
isEvaldUnfolding (OtherCon _) = True
isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
-isEvaldUnfolding other = False
+isEvaldUnfolding _ = False
isCheapUnfolding :: Unfolding -> Bool
isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
-isCheapUnfolding other = False
+isCheapUnfolding _ = False
isCompulsoryUnfolding :: Unfolding -> Bool
isCompulsoryUnfolding (CompulsoryUnfolding _) = True
-isCompulsoryUnfolding other = False
+isCompulsoryUnfolding _ = False
hasUnfolding :: Unfolding -> Bool
hasUnfolding (CoreUnfolding _ _ _ _ _) = True
hasUnfolding (CompulsoryUnfolding _) = True
-hasUnfolding other = False
+hasUnfolding _ = False
hasSomeUnfolding :: Unfolding -> Bool
hasSomeUnfolding NoUnfolding = False
-hasSomeUnfolding other = True
+hasSomeUnfolding _ = True
neverUnfold :: Unfolding -> Bool
neverUnfold NoUnfolding = True
neverUnfold (OtherCon _) = True
neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
-neverUnfold other = False
+neverUnfold _ = False
\end{code}
cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
ltAlt :: Alt b -> Alt b -> Bool
-ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
+ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
cmpAltCon :: AltCon -> AltCon -> Ordering
-- Compares AltCons within a single list of alternatives
cmpAltCon DEFAULT DEFAULT = EQ
-cmpAltCon DEFAULT con = LT
+cmpAltCon DEFAULT _ = LT
cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
cmpAltCon (DataAlt _) DEFAULT = GT
\begin{code}
coreExprCc :: Expr b -> CostCentre
-coreExprCc (Note (SCC cc) e) = cc
-coreExprCc (Note other_note e) = coreExprCc e
+coreExprCc (Note (SCC cc) _) = cc
+coreExprCc (Note _ e) = coreExprCc e
coreExprCc (Lam _ e) = coreExprCc e
-coreExprCc other = noCostCentre
+coreExprCc _ = noCostCentre
\end{code}
\begin{code}
isRuntimeVar :: Var -> Bool
-isRuntimeVar | opt_RuntimeTypes = \v -> True
+isRuntimeVar | opt_RuntimeTypes = \_ -> True
| otherwise = \v -> isId v
isRuntimeArg :: CoreExpr -> Bool
-isRuntimeArg | opt_RuntimeTypes = \e -> True
+isRuntimeArg | opt_RuntimeTypes = \_ -> True
| otherwise = \e -> isValArg e
\end{code}
\begin{code}
+isValArg :: Expr b -> Bool
isValArg (Type _) = False
-isValArg other = True
+isValArg _ = True
+isTypeArg :: Expr b -> Bool
isTypeArg (Type _) = True
-isTypeArg other = False
+isTypeArg _ = False
valBndrCount :: [CoreBndr] -> Int
-valBndrCount [] = 0
-valBndrCount (b : bs) | isId b = 1 + valBndrCount bs
- | otherwise = valBndrCount bs
+valBndrCount = count isId
valArgCount :: [Arg b] -> Int
-valArgCount [] = 0
-valArgCount (Type _ : args) = valArgCount args
-valArgCount (other : args) = 1 + valArgCount args
+valArgCount = count isValArg
\end{code}
seqExpr (Note n e) = seqNote n `seq` seqExpr e
seqExpr (Type t) = seqType t
+seqExprs :: [CoreExpr] -> ()
seqExprs [] = ()
seqExprs (e:es) = seqExpr e `seq` seqExprs es
+seqNote :: Note -> ()
seqNote (CoreNote s) = s `seq` ()
-seqNote other = ()
+seqNote _ = ()
+seqBndr :: CoreBndr -> ()
seqBndr b = b `seq` ()
+seqBndrs :: [CoreBndr] -> ()
seqBndrs [] = ()
seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
+seqBind :: Bind CoreBndr -> ()
seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
seqBind (Rec prs) = seqPairs prs
+seqPairs :: [(CoreBndr, CoreExpr)] -> ()
seqPairs [] = ()
seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
+seqAlts :: [CoreAlt] -> ()
seqAlts [] = ()
-seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
+seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
+seqRules :: [CoreRule] -> ()
seqRules [] = ()
seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
= seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
deAnnotate :: AnnExpr bndr annot -> Expr bndr
deAnnotate (_, e) = deAnnotate' e
+deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
deAnnotate' (AnnType t) = Type t
deAnnotate' (AnnVar v) = Var v
deAnnotate' (AnnLit lit) = Lit lit
projects / ghc-hetmet.git / blobdiff