Commit b04296d3 authored by Austin Seipp's avatar Austin Seipp

compiler: de-lhs coreSyn/

Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent 9fc4382c
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
Arity and eta expansion
-}
\begin{code}
{-# LANGUAGE CPP #-}
-- | Arity and eta expansion
......@@ -34,13 +34,13 @@ import Outputable
import FastString
import Pair
import Util ( debugIsOn )
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
manifestArity and exprArity
%* *
%************************************************************************
* *
************************************************************************
exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
It tells how many things the expression can be applied to before doing
......@@ -65,8 +65,8 @@ won't be eta-expanded.
And in any case it seems more robust to have exprArity be a bit more intelligent.
But note that (\x y z -> f x y z)
should have arity 3, regardless of f's arity.
-}
\begin{code}
manifestArity :: CoreExpr -> Arity
-- ^ manifestArity sees how many leading value lambdas there are,
-- after looking through casts
......@@ -142,8 +142,8 @@ exprBotStrictness_maybe e
env = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False }
sig ar = mkClosedStrictSig (replicate ar topDmd) botRes
-- For this purpose we can be very simple
\end{code}
{-
Note [exprArity invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~
exprArity has the following invariant:
......@@ -238,11 +238,11 @@ When we come to an application we check that the arg is trivial.
unknown, hence arity 0
%************************************************************************
%* *
************************************************************************
* *
Computing the "arity" of an expression
%* *
%************************************************************************
* *
************************************************************************
Note [Definition of arity]
~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -465,7 +465,8 @@ Then f :: AT [False,False] ATop
f <expensive> :: AT [] ATop
-------------------- Main arity code ----------------------------
\begin{code}
-}
-- See Note [ArityType]
data ArityType = ATop [OneShotInfo] | ABot Arity
-- There is always an explicit lambda
......@@ -559,8 +560,8 @@ rhsEtaExpandArity dflags cheap_app e
has_lam (Tick _ e) = has_lam e
has_lam (Lam b e) = isId b || has_lam e
has_lam _ = False
\end{code}
{-
Note [Arity analysis]
~~~~~~~~~~~~~~~~~~~~~
The motivating example for arity analysis is this:
......@@ -628,8 +629,8 @@ PAPSs
because that might in turn make g inline (if it has an inline pragma),
which we might not want. After all, INLINE pragmas say "inline only
when saturated" so we don't want to be too gung-ho about saturating!
-}
\begin{code}
arityLam :: Id -> ArityType -> ArityType
arityLam id (ATop as) = ATop (idOneShotInfo id : as)
arityLam _ (ABot n) = ABot (n+1)
......@@ -660,8 +661,8 @@ andArityType (ATop as) (ATop bs) = ATop (as `combine` bs)
combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs
combine [] bs = takeWhile isOneShotInfo bs
combine as [] = takeWhile isOneShotInfo as
\end{code}
{-
Note [Combining case branches]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
......@@ -679,8 +680,8 @@ lambda wasn't one-shot we don't want to do this.
So we combine the best of the two branches, on the (slightly dodgy)
basis that if we know one branch is one-shot, then they all must be.
-}
\begin{code}
---------------------------
type CheapFun = CoreExpr -> Maybe Type -> Bool
-- How to decide if an expression is cheap
......@@ -767,14 +768,13 @@ arityType env (Tick t e)
| not (tickishIsCode t) = arityType env e
arityType _ _ = vanillaArityType
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
The main eta-expander
%* *
%************************************************************************
* *
************************************************************************
We go for:
f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym
......@@ -822,8 +822,8 @@ Note that SCCs are not treated specially by etaExpand. If we have
etaExpand 2 (\x -> scc "foo" e)
= (\xy -> (scc "foo" e) y)
So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
-}
\begin{code}
-- | @etaExpand n us e ty@ returns an expression with
-- the same meaning as @e@, but with arity @n@.
--
......@@ -1001,4 +1001,3 @@ freshEtaId n subst ty
eta_id' = uniqAway (getTvInScope subst) $
mkSysLocal (fsLit "eta") (mkBuiltinUnique n) ty'
subst' = extendTvInScope subst eta_id'
\end{code}
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
Taken quite directly from the Peyton Jones/Lester paper.
-}
\begin{code}
{-# LANGUAGE CPP #-}
-- | A module concerned with finding the free variables of an expression.
......@@ -20,7 +20,7 @@ module CoreFVs (
exprSomeFreeVars, exprsSomeFreeVars,
-- * Free variables of Rules, Vars and Ids
varTypeTyVars,
varTypeTyVars,
idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
......@@ -50,14 +50,13 @@ import Maybes( orElse )
import Util
import BasicTypes( Activation )
import Outputable
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\section{Finding the free variables of an expression}
%* *
%************************************************************************
* *
************************************************************************
This function simply finds the free variables of an expression.
So far as type variables are concerned, it only finds tyvars that are
......@@ -66,8 +65,8 @@ So far as type variables are concerned, it only finds tyvars that are
* free in the type of a binder,
but not those that are free in the type of variable occurrence.
-}
\begin{code}
-- | Find all locally-defined free Ids or type variables in an expression
exprFreeVars :: CoreExpr -> VarSet
exprFreeVars = exprSomeFreeVars isLocalVar
......@@ -101,14 +100,11 @@ exprsSomeFreeVars fv_cand = mapUnionVarSet (exprSomeFreeVars fv_cand)
-- | Predicate on possible free variables: returns @True@ iff the variable is interesting
type InterestingVarFun = Var -> Bool
\end{code}
\begin{code}
type FV = InterestingVarFun
-> VarSet -- Locally bound
-> VarSet -- Free vars
-- Return the vars that are both (a) interesting
-- Return the vars that are both (a) interesting
-- and (b) not locally bound
-- See function keep_it
......@@ -172,10 +168,7 @@ addBndr bndr fv fv_cand in_scope
addBndrs :: [CoreBndr] -> FV -> FV
addBndrs bndrs fv = foldr addBndr fv bndrs
\end{code}
\begin{code}
expr_fvs :: CoreExpr -> FV
expr_fvs (Type ty) = someVars (tyVarsOfType ty)
......@@ -213,16 +206,15 @@ exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
tickish_fvs :: Tickish Id -> FV
tickish_fvs (Breakpoint _ ids) = someVars (mkVarSet ids)
tickish_fvs _ = noVars
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\section{Free names}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
-- | ruleLhsOrphNames is used when deciding whether
-- a rule is an orphan. In particular, suppose that T is defined in this
-- module; we want to avoid declaring that a rule like:
......@@ -268,15 +260,15 @@ exprOrphNames e
-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details
exprsOrphNames :: [CoreExpr] -> NameSet
exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\section[freevars-everywhere]{Attaching free variables to every sub-expression}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
-- | Those variables free in the right hand side of a rule
ruleRhsFreeVars :: CoreRule -> VarSet
ruleRhsFreeVars (BuiltinRule {}) = noFVs
......@@ -314,8 +306,8 @@ ruleLhsFreeIds :: CoreRule -> VarSet
ruleLhsFreeIds (BuiltinRule {}) = noFVs
ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
= addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
\end{code}
{-
Note [Rule free var hack] (Not a hack any more)
~~~~~~~~~~~~~~~~~~~~~~~~~
We used not to include the Id in its own rhs free-var set.
......@@ -326,8 +318,8 @@ However, the occurrence analyser distinguishes "non-rule loop breakers"
from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will
put this 'f' in a Rec block, but will mark the binding as a non-rule loop
breaker, which is perfectly inlinable.
-}
\begin{code}
-- |Free variables of a vectorisation declaration
vectsFreeVars :: [CoreVect] -> VarSet
vectsFreeVars = mapUnionVarSet vectFreeVars
......@@ -338,19 +330,18 @@ vectsFreeVars = mapUnionVarSet vectFreeVars
vectFreeVars (VectClass _) = noFVs
vectFreeVars (VectInst _) = noFVs
-- this function is only concerned with values, not types
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\section[freevars-everywhere]{Attaching free variables to every sub-expression}
%* *
%************************************************************************
* *
************************************************************************
The free variable pass annotates every node in the expression with its
NON-GLOBAL free variables and type variables.
-}
\begin{code}
-- | Every node in a binding group annotated with its
-- (non-global) free variables, both Ids and TyVars
type CoreBindWithFVs = AnnBind Id VarSet
......@@ -444,22 +435,21 @@ stableUnfoldingVars :: Unfolding -> Maybe VarSet
stableUnfoldingVars unf
= case unf of
CoreUnfolding { uf_tmpl = rhs, uf_src = src }
| isStableSource src
| isStableSource src
-> Just (exprFreeVars rhs)
DFunUnfolding { df_bndrs = bndrs, df_args = args }
DFunUnfolding { df_bndrs = bndrs, df_args = args }
-> Just (exprs_fvs args isLocalVar (mkVarSet bndrs))
-- DFuns are top level, so no fvs from types of bndrs
_other -> Nothing
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{Free variables (and types)}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
freeVars :: CoreExpr -> CoreExprWithFVs
-- ^ Annotate a 'CoreExpr' with its (non-global) free type and value variables at every tree node
freeVars (Var v)
......@@ -541,5 +531,3 @@ freeVars (Tick tickish expr)
freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co)
\end{code}
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
A ``lint'' pass to check for Core correctness
-}
\begin{code}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fprof-auto #-}
......@@ -48,8 +47,8 @@ import Control.Monad
import MonadUtils
import Data.Maybe
import Pair
\end{code}
{-
Note [GHC Formalism]
~~~~~~~~~~~~~~~~~~~~
This file implements the type-checking algorithm for System FC, the "official"
......@@ -62,11 +61,11 @@ just about anything in this file or you change other types/functions throughout
the Core language (all signposted to this note), you should update that
formalism. See docs/core-spec/README for more info about how to do so.
%************************************************************************
%* *
************************************************************************
* *
\subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
%* *
%************************************************************************
* *
************************************************************************
Checks that a set of core bindings is well-formed. The PprStyle and String
just control what we print in the event of an error. The Bool value
......@@ -111,9 +110,8 @@ to the type of the binding variable. lintBinders does this.
For Ids, the type-substituted Id is added to the in_scope set (which
itself is part of the TvSubst we are carrying down), and when we
find an occurrence of an Id, we fetch it from the in-scope set.
-}
\begin{code}
lintCoreBindings :: [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
-- Returns (warnings, errors)
-- If you edit this function, you may need to update the GHC formalism
......@@ -149,18 +147,18 @@ lintCoreBindings local_in_scope binds
-- See Note [GHC Formalism]
lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection[lintUnfolding]{lintUnfolding}
%* *
%************************************************************************
* *
************************************************************************
We use this to check all unfoldings that come in from interfaces
(it is very painful to catch errors otherwise):
-}
\begin{code}
lintUnfolding :: SrcLoc
-> [Var] -- Treat these as in scope
-> CoreExpr
......@@ -185,17 +183,17 @@ lintExpr vars expr
(_warns, errs) = initL (addLoc TopLevelBindings $
addInScopeVars vars $
lintCoreExpr expr)
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection[lintCoreBinding]{lintCoreBinding}
%* *
%************************************************************************
* *
************************************************************************
Check a core binding, returning the list of variables bound.
-}
\begin{code}
lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
......@@ -263,15 +261,15 @@ lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
; checkTys bndr_ty ty (mkRhsMsg bndr (ptext (sLit "unfolding")) ty) }
lintIdUnfolding _ _ _
= return () -- We could check more
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection[lintCoreExpr]{lintCoreExpr}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
--type InKind = Kind -- Substitution not yet applied
type InType = Type
type InCoercion = Coercion
......@@ -415,8 +413,7 @@ lintCoreExpr (Coercion co)
= do { (_kind, ty1, ty2, role) <- lintInCo co
; return (mkCoercionType role ty1 ty2) }
\end{code}
{-
Note [Kind instantiation in coercions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following coercion axiom:
......@@ -436,16 +433,16 @@ kind coercions and produce the following substitution which is to be
applied in the type variables:
k_ag ~~> * -> *
%************************************************************************
%* *
************************************************************************
* *
\subsection[lintCoreArgs]{lintCoreArgs}
%* *
%************************************************************************
* *
************************************************************************
The basic version of these functions checks that the argument is a
subtype of the required type, as one would expect.
-}
\begin{code}
lintCoreArg :: OutType -> CoreArg -> LintM OutType
lintCoreArg fun_ty (Type arg_ty)
= do { arg_ty' <- applySubstTy arg_ty
......@@ -496,9 +493,7 @@ lintValApp arg fun_ty arg_ty
where
err1 = mkAppMsg fun_ty arg_ty arg
err2 = mkNonFunAppMsg fun_ty arg_ty arg
\end{code}
\begin{code}
checkTyKind :: OutTyVar -> OutType -> LintM ()
-- Both args have had substitution applied
......@@ -528,16 +523,15 @@ checkDeadIdOcc id
(ptext (sLit "Occurrence of a dead Id") <+> ppr id) }
| otherwise
= return ()
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection[lintCoreAlts]{lintCoreAlts}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
-- a) Check that the alts are non-empty
-- b1) Check that the DEFAULT comes first, if it exists
......@@ -574,9 +568,7 @@ checkCaseAlts e ty alts =
is_infinite_ty = case tyConAppTyCon_maybe ty of
Nothing -> False
Just tycon -> isPrimTyCon tycon
\end{code}
\begin{code}
checkAltExpr :: CoreExpr -> OutType -> LintM ()
checkAltExpr expr ann_ty
= do { actual_ty <- lintCoreExpr expr
......@@ -620,15 +612,15 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
| otherwise -- Scrut-ty is wrong shape
= addErrL (mkBadAltMsg scrut_ty alt)
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection[lint-types]{Types}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
-- When we lint binders, we (one at a time and in order):
-- 1. Lint var types or kinds (possibly substituting)
-- 2. Add the binder to the in scope set, and if its a coercion var,
......@@ -675,20 +667,19 @@ lintAndScopeId id linterF
= do { ty <- lintInTy (idType id)
; let id' = setIdType id ty
; addInScopeVar id' $ (linterF id') }
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Types and kinds
%* *
%************************************************************************
* *
************************************************************************
We have a single linter for types and kinds. That is convenient
because sometimes it's not clear whether the thing we are looking
at is a type or a kind.
-}
\begin{code}
lintInTy :: InType -> LintM LintedType
-- Types only, not kinds
-- Check the type, and apply the substitution to it
......@@ -746,10 +737,6 @@ lintType (ForAllTy tv ty)
lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)
\end{code}
\begin{code}
lintKind :: OutKind -> LintM ()
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
......@@ -757,10 +744,7 @@ lintKind k = do { sk <- lintType k
; unless (isSuperKind sk)
(addErrL (hang (ptext (sLit "Ill-kinded kind:") <+> ppr k)
2 (ptext (sLit "has kind:") <+> ppr sk))) }
\end{code}
\begin{code}
lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
......@@ -823,15 +807,15 @@ lint_app doc kfn kas
; return (substKiWith [kv] [ta] kfn) }
go_app _ _ = failWithL fail_msg
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Linting coercions
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
lintInCo :: InCoercion -> LintM (LintedKind, LintedType, LintedType, Role)
-- Check the coercion, and apply the substitution to it
-- See Note [Linting type lets]
......@@ -1053,15 +1037,13 @@ lintCoercion this@(AxiomRuleCo co ts cs)
[ txt "Expected:" <+> int (n + length es)
, txt "Provided:" <+> int n ]
\end{code}