Commit 69e14f75 authored by simonpj's avatar simonpj

[project @ 1999-05-18 15:03:54 by simonpj]

RULES-NOTES
parent c9dfd084
......@@ -4,17 +4,18 @@
Taken quite directly from the Peyton Jones/Lester paper.
\begin{code}
module FreeVars (
freeVars,
freeVarsOf,
CoreExprWithFVs, CoreBindWithFVs
module CoreFVs (
exprFreeVars, exprsFreeVars,
exprSomeFreeVars, exprsSomeFreeVars,
idRuleVars, idFreeVars, ruleSomeFreeVars, ruleSomeLhsFreeVars,
CoreExprWithFVs, CoreBindWithFVs, freeVars, freeVarsOf,
) where
#include "HsVersions.h"
import CoreSyn
import CoreUtils ( idFreeVars )
import Id ( Id )
import Id ( Id, idFreeTyVars, getIdSpecialisation )
import VarSet
import Var ( IdOrTyVar, isId )
import Name ( isLocallyDefined )
......@@ -24,7 +25,140 @@ import Util ( mapAndUnzip )
%************************************************************************
%* *
\section[freevars-everywhere]{Attaching free variables to every sub-expression
\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
* free in type arguments,
* free in the type of a binder,
but not those that are free in the type of variable occurrence.
\begin{code}
exprFreeVars :: CoreExpr -> IdOrTyVarSet -- Find all locally-defined free Ids or tyvars
exprFreeVars = exprSomeFreeVars isLocallyDefined
exprsFreeVars :: [CoreExpr] -> IdOrTyVarSet
exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
-> CoreExpr
-> IdOrTyVarSet
exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
exprsSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
-> [CoreExpr]
-> IdOrTyVarSet
exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet
type InterestingVarFun = IdOrTyVar -> Bool -- True <=> interesting
\end{code}
\begin{code}
type FV = InterestingVarFun
-> IdOrTyVarSet -- In scope
-> IdOrTyVarSet -- Free vars
union :: FV -> FV -> FV
union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
noVars :: FV
noVars fv_cand in_scope = emptyVarSet
-- At a variable occurrence, add in any free variables of its rule rhss
-- Curiously, we gather the Id's free *type* variables from its binding
-- site, but its free *rule-rhs* variables from its usage sites. This
-- is a little weird. The reason is that the former is more efficient,
-- but the latter is more fine grained, and a makes a difference when
-- a variable mentions itself one of its own rule RHSs
oneVar :: IdOrTyVar -> FV
oneVar var fv_cand in_scope
= foldVarSet add_rule_var var_itself_set (idRuleVars var)
where
var_itself_set | keep_it fv_cand in_scope var = unitVarSet var
| otherwise = emptyVarSet
add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
| otherwise = set
someVars :: IdOrTyVarSet -> FV
someVars vars fv_cand in_scope
= filterVarSet (keep_it fv_cand in_scope) vars
keep_it fv_cand in_scope var
| var `elemVarSet` in_scope = False
| fv_cand var = True
| otherwise = False
addBndr :: CoreBndr -> FV -> FV
addBndr bndr fv fv_cand in_scope
| isId bndr = inside_fvs `unionVarSet` someVars (idFreeTyVars bndr) fv_cand in_scope
| otherwise = inside_fvs
where
inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr)
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)
expr_fvs (Var var) = oneVar var
expr_fvs (Con con args) = foldr (union . expr_fvs) noVars args
expr_fvs (Note _ expr) = expr_fvs expr
expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
expr_fvs (Case scrut bndr alts)
= expr_fvs scrut `union` addBndr bndr (foldr (union . alt_fvs) noVars alts)
where
alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
expr_fvs (Let (NonRec bndr rhs) body)
= expr_fvs rhs `union` addBndr bndr (expr_fvs body)
expr_fvs (Let (Rec pairs) body)
= addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
where
(bndrs,rhss) = unzip pairs
\end{code}
\begin{code}
idRuleVars ::Id -> IdOrTyVarSet
idRuleVars id = rulesRhsFreeVars (getIdSpecialisation id)
idFreeVars :: Id -> IdOrTyVarSet
idFreeVars id = idRuleVars id `unionVarSet` idFreeTyVars id
rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> IdOrTyVarSet
rulesSomeFreeVars interesting (Rules rules _)
= foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules
ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> IdOrTyVarSet
ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs)
= rule_fvs interesting emptyVarSet
where
rule_fvs = addBndrs tpl_vars $
foldr (union . expr_fvs) (expr_fvs rhs) tpl_args
ruleSomeLhsFreeVars :: InterestingVarFun -> CoreRule -> IdOrTyVarSet
ruleSomeLhsFreeVars fn (Rule _ tpl_vars tpl_args rhs)
= foldl delVarSet (exprsSomeFreeVars fn tpl_args) tpl_vars
\end{code}
%************************************************************************
%* *
\section[freevars-everywhere]{Attaching free variables to every sub-expression}
%* *
%************************************************************************
......
......@@ -14,16 +14,17 @@ module CoreLint (
import IO ( hPutStr, stderr )
import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting )
import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
import CoreSyn
import CoreUtils ( idFreeVars )
import CoreFVs ( idFreeVars )
import CoreUtils ( exprOkForSpeculation )
import Bag
import Const ( Con(..), DataCon, conType, conOkForApp, conOkForAlt )
import Id ( isConstantId, idMustBeINLINEd )
import Var ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar, isId )
import VarSet
import VarEnv ( mkVarEnv )
import Subst ( mkTyVarSubst, substTy )
import Name ( isLocallyDefined, getSrcLoc )
import PprCore
import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message,
......@@ -33,12 +34,13 @@ import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc )
import Type ( Type, Kind, tyVarsOfType,
splitFunTy_maybe, mkPiType, mkTyVarTy,
splitForAllTy_maybe, splitTyConApp_maybe,
isUnLiftedType, typeKind, substTy,
isUnLiftedType, typeKind,
splitAlgTyConApp_maybe,
isUnboxedTupleType,
hasMoreBoxityInfo
)
import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
import BasicTypes ( RecFlag(..), isNonRec )
import Outputable
infixr 9 `thenL`, `seqL`
......@@ -122,10 +124,15 @@ lintCoreBindings whoDunnit binds
Just bad_news -> printDump (display bad_news) >>
ghcExit 1
where
lint_binds [] = returnL ()
lint_binds (bind:binds)
= lintCoreBinding bind `thenL` \binders ->
addInScopeVars binders (lint_binds binds)
-- Put all the top-level binders in scope at the start
-- This is because transformation rules can bring something
-- into use 'unexpectedly'
lint_binds binds = addInScopeVars (bindersOfBinds binds) $
mapL lint_bind binds
lint_bind (Rec prs) = mapL (lintSingleBinding Recursive) prs `seqL`
returnL ()
lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
display bad_news
= vcat [
......@@ -150,26 +157,16 @@ We use this to check all unfoldings that come in from interfaces
lintUnfolding :: SrcLoc
-> [IdOrTyVar] -- Treat these as in scope
-> CoreExpr
-> Maybe CoreExpr
-> Maybe Message -- Nothing => OK
lintUnfolding locn vars expr
| not opt_DoCoreLinting
= Just expr
= Nothing
| otherwise
= case
initL (addLoc (ImportedUnfolding locn) $
= initL (addLoc (ImportedUnfolding locn) $
addInScopeVars vars $
lintCoreExpr expr)
of
Nothing -> Just expr
Just msg ->
pprTrace "WARNING: Discarded bad unfolding from interface:\n"
(vcat [msg,
ptext SLIT("*** Bad unfolding ***"),
ppr expr,
ptext SLIT("*** End unfolding ***")])
Nothing
\end{code}
%************************************************************************
......@@ -181,19 +178,7 @@ lintUnfolding locn vars expr
Check a core binding, returning the list of variables bound.
\begin{code}
lintCoreBinding :: CoreBind -> LintM [Id]
lintCoreBinding (NonRec binder rhs)
= lintSingleBinding (binder,rhs) `seqL` returnL [binder]
lintCoreBinding (Rec pairs)
= addInScopeVars binders (
mapL lintSingleBinding pairs `seqL` returnL binders
)
where
binders = map fst pairs
lintSingleBinding (binder,rhs)
lintSingleBinding rec_flag (binder,rhs)
= addLoc (RhsOf binder) $
-- Check the rhs
......@@ -204,7 +189,7 @@ lintSingleBinding (binder,rhs)
checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
-- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
checkL (not (isUnLiftedType binder_ty))
checkL (not (isUnLiftedType binder_ty) || (isNonRec rec_flag && exprOkForSpeculation rhs))
(mkRhsPrimMsg binder rhs) `seqL`
-- Check whether binder's specialisations contain any out-of-scope variables
......@@ -252,13 +237,17 @@ lintCoreExpr (Note (Coerce to_ty from_ty) expr)
lintCoreExpr (Note other_note expr)
= lintCoreExpr expr
lintCoreExpr (Let binds body)
= lintCoreBinding binds `thenL` \binders ->
if (null binders) then
lintCoreExpr body -- Can't add a new source location
else
addLoc (BodyOfLetRec binders)
(addInScopeVars binders (lintCoreExpr body))
lintCoreExpr (Let (NonRec bndr rhs) body)
= lintSingleBinding NonRecursive (bndr,rhs) `seqL`
addLoc (BodyOfLetRec [bndr])
(addInScopeVars [bndr] (lintCoreExpr body))
lintCoreExpr (Let (Rec pairs) body)
= addInScopeVars bndrs $
mapL (lintSingleBinding Recursive) pairs `seqL`
addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
where
bndrs = map fst pairs
lintCoreExpr e@(Con con args)
= addLoc (AnExpr e) $
......@@ -357,7 +346,7 @@ lintTyApp ty arg_ty
-- error :: forall a:*. String -> a
-- and then apply it to both boxed and unboxed types.
then
returnL (substTy (mkVarEnv [(tyvar,arg_ty)]) body)
returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
else
addErrL (mkKindErrMsg tyvar arg_ty)
......@@ -541,11 +530,14 @@ addErr errs_so_far msg locs
= ASSERT (not (null locs))
errs_so_far `snocBag` mk_msg msg
where
(loc, pref) = dumpLoc (head locs)
(loc, cxt1) = dumpLoc (head locs)
cxts = [snd (dumpLoc loc) | loc <- locs]
context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
| otherwise = cxt1
mk_msg msg
| isNoSrcLoc loc = (loc, hang pref 4 msg)
| otherwise = addErrLocHdrLine loc pref msg
| isNoSrcLoc loc = (loc, hang context 4 msg)
| otherwise = addErrLocHdrLine loc context msg
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m loc scope errs
......
_interface_ CoreSyn 1
_exports_
CoreSyn CoreExpr ;
CoreSyn CoreExpr CoreRule CoreRules emptyCoreRules isEmptyCoreRules ;
_declarations_
-- Needed by IdInfo
1 type CoreExpr = Expr Var.IdOrTyVar;
1 data Expr b ;
1 data CoreRule ;
1 type CoreRules = [CoreRule] ;
1 emptyCoreRules _:_ CoreRules ;;
1 isEmptyCoreRules _:_ CoreRules -> PrelBase.Bool ;;
__interface CoreSyn 1 0 where
__export CoreSyn CoreExpr ;
__export CoreSyn CoreExpr CoreRules CoreRule emptyCoreRules ;
-- Needed by IdInfo
1 type CoreExpr = Expr Var.IdOrTyVar;
1 data Expr b ;
1 data CoreRule ;
1 type CoreRules = [CoreRule] ;
1 emptyCoreRules :: CoreRules ;
......@@ -9,20 +9,26 @@ module CoreSyn (
CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
TaggedExpr, TaggedAlt, TaggedBind, TaggedArg,
mkLets, mkLetBinds, mkLams,
mkLets, mkLams,
mkApps, mkTyApps, mkValApps,
mkLit, mkStringLit, mkConApp, mkPrimApp, mkNote, mkNilExpr,
mkLit, mkStringLit, mkConApp, mkPrimApp, mkNote,
bindNonRec, mkIfThenElse, varToCoreExpr,
bindersOf, rhssOfBind, rhssOfAlts, isDeadBinder, isTyVar, isId,
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isDeadBinder, isTyVar, isId,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
collectArgs,
collectArgs, collectBindersIgnoringNotes,
coreExprCc,
flattenBinds,
isValArg, isTypeArg, valArgCount,
isValArg, isTypeArg, valArgCount, valBndrCount,
-- Annotated expressions
AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate
AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate,
-- Core rules
CoreRules(..), -- Representation needed by friends
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules
) where
#include "HsVersions.h"
......@@ -30,11 +36,13 @@ module CoreSyn (
import TysWiredIn ( boolTy, stringTy, nilDataCon )
import CostCentre ( CostCentre, isDupdCC, noCostCentre )
import Var ( Var, Id, TyVar, IdOrTyVar, isTyVar, isId, idType )
import VarEnv
import Id ( mkWildId, getInlinePragma )
import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType )
import IdInfo ( InlinePragInfo(..) )
import Const ( Con(..), DataCon, Literal(NoRepStr), PrimOp )
import TysWiredIn ( trueDataCon, falseDataCon )
import VarSet
import Outputable
\end{code}
......@@ -47,6 +55,8 @@ import Outputable
These data types are the heart of the compiler
\begin{code}
infixl 8 `App` -- App brackets to the left
data Expr b -- "b" for the type of binders,
= Var Id
| Con Con [Arg b] -- Guaranteed saturated
......@@ -80,11 +90,48 @@ data Note
| 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
| TermUsg -- A term-level usage annotation
UsageAnn -- (should not be a variable except during UsageSP inference)
\end{code}
%************************************************************************
%* *
\subsection{Transformation rules}
%* *
%************************************************************************
The CoreRule type and its friends are dealt with mainly in CoreRules,
but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
\begin{code}
data CoreRules
= Rules [CoreRule]
IdOrTyVarSet -- Locally-defined free vars of RHSs
data CoreRule
= Rule FAST_STRING -- Rule name
[CoreBndr] -- Forall'd variables
[CoreExpr] -- LHS args
CoreExpr -- RHS
emptyCoreRules :: CoreRules
emptyCoreRules = Rules [] emptyVarSet
isEmptyCoreRules :: CoreRules -> Bool
isEmptyCoreRules (Rules rs _) = null rs
rulesRhsFreeVars :: CoreRules -> IdOrTyVarSet
rulesRhsFreeVars (Rules _ fvs) = fvs
rulesRules :: CoreRules -> [CoreRule]
rulesRules (Rules rules _) = rules
\end{code}
%************************************************************************
%* *
\subsection{Useful synonyms}
......@@ -139,9 +186,6 @@ 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)
......@@ -156,13 +200,6 @@ mkLams binders body = foldr Lam body binders
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
......@@ -170,7 +207,10 @@ bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
-- case r of x { _DEFAULT_ -> b }
--
-- depending on whether x is unlifted or not
bindNonRec bndr rhs body
-- It's used by the desugarer to avoid building bindings
-- that give Core Lint a heart attack. Actually the simplifier
-- deals with them perfectly well.
bindNonRec bndr rhs body
| isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
| otherwise = Let (NonRec bndr rhs) body
......@@ -196,10 +236,15 @@ mkNote (SCC cc1) expr@(Note (SCC cc2) _)
mkNote note@(SCC cc1) expr@(Lam x e) -- Move _scc_ inside lambda
= Lam x (mkNote note e)
-- Drop trivial InlineMe's
mkNote InlineMe expr@(Con _ _) = expr
mkNote InlineMe expr@(Var v) = expr
-- 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
-- No longer necessary I think (SLPJ Apr 99)
-- 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}
......@@ -215,6 +260,9 @@ 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]
......@@ -227,6 +275,11 @@ isDeadBinder bndr | isId bndr = case getInlinePragma bndr of
IAmDead -> True
other -> False
| otherwise = False -- TyVars count as not dead
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
......@@ -236,10 +289,27 @@ We expect (by convention) type-, and value- lambdas in that
order.
\begin{code}
collectBinders :: Expr b -> ([b], Expr b)
collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
collectValBinders :: CoreExpr -> ([Id], CoreExpr)
collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
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)
collectBinders expr
= go [] expr
where
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)
......@@ -247,12 +317,6 @@ collectTyAndValBinders expr
(tvs, body1) = collectTyBinders expr
(ids, body) = collectValBinders body1
collectBinders expr
= go [] expr
where
go tvs (Lam b e) = go (b:tvs) e
go tvs e = (reverse tvs, e)
collectTyBinders expr
= go [] expr
where
......@@ -304,6 +368,11 @@ 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
valArgCount :: [Arg b] -> Int
valArgCount [] = 0
valArgCount (Type _ : args) = valArgCount args
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section{Tidying up Core}
\begin{code}
module CoreTidy (
tidyCorePgm, tidyExpr,
tidyBndr, tidyBndrs
) where
#include "HsVersions.h"
import CmdLineOpts ( opt_D_dump_simpl, opt_D_verbose_core2core, opt_UsageSPOn )
import CoreSyn
import CoreUnfold ( noUnfolding )
import CoreLint ( beginPass, endPass )
import Rules ( ProtoCoreRule(..) )
import VarEnv
import VarSet
import Var ( Id, IdOrTyVar )
import Id ( idType, idInfo, idName,
mkVanillaId, mkId, isUserExportedId,
getIdStrictness, setIdStrictness,
getIdDemandInfo, setIdDemandInfo,
)
import IdInfo ( specInfo, setSpecInfo,
inlinePragInfo, setInlinePragInfo, InlinePragInfo(..),
setUnfoldingInfo, setDemandInfo
)
import Demand ( wwLazy )
import Name ( getOccName, tidyTopName, mkLocalName, isLocallyDefined )
import OccName ( initTidyOccEnv, tidyOccName )
import Type ( tidyTopType, tidyType, tidyTypes, tidyTyVar, tidyTyVars )
import Class ( Class, classSelIds )
import Module ( Module )
import UniqSupply ( UniqSupply )
import Unique ( Uniquable(..) )
import SrcLoc ( noSrcLoc )
import Util ( mapAccumL )
import Outputable
doUsageSPInf = panic "doUsageSpInf"
\end{code}
%************************************************************************
%* *
\subsection{Tidying core}
%* *
%************************************************************************
Several tasks are done by @tidyCorePgm@
1. Make certain top-level bindings into Globals. The point is that
Global things get externally-visible labels at code generation
time
2. Give all binders a nice print-name. Their uniques aren't changed;
rather we give them lexically unique occ-names, so that we can
safely print the OccNae only in the interface file. [Bad idea to
change the uniques, because the code generator makes global labels
from the uniques for local thunks etc.]
3. If @opt_UsageSPOn@ then compute usage information (which is
needed by Core2Stg). ** NOTE _scc_ HERE **
\begin{code}
tidyCorePgm :: UniqSupply -> Module -> [CoreBind] -> [ProtoCoreRule]
-> IO ([CoreBind], [ProtoCoreRule])
tidyCorePgm us module_name binds_in rules
= do
beginPass "Tidy Core"
let (tidy_env1, binds_tidy) = mapAccumL (tidyBind (Just module_name)) init_tidy_env binds_in
rules_out = tidyProtoRules tidy_env1 rules
binds_out <- if opt_UsageSPOn
then _scc_ "CoreUsageSPInf" doUsageSPInf us binds_tidy
else return binds_tidy
endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
return (binds_out, rules_out)
where
-- We also make sure to avoid any exported binders. Consider
-- f{-u1-} = 1 -- Local decl
-- ...
-- f{-u2-} = 2 -- Exported decl
--
-- The second exported decl must 'get' the name 'f', so we
-- have to put 'f' in the avoids list before we get to the first
-- decl. tidyTopId then does a no-op on exported binders.
init_tidy_env = (initTidyOccEnv avoids, emptyVarEnv)
avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
isUserExportedId bndr]
tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested
-> TidyEnv
-> CoreBind
-> (TidyEnv, CoreBind)
tidyBind maybe_mod env (NonRec bndr rhs)
= let
(env', bndr') = tidy_bndr maybe_mod env bndr
rhs' = tidyExpr env rhs
in
(env', NonRec bndr' rhs')
tidyBind maybe_mod env (Rec pairs)
= let
-- We use env' when tidying the rhss
-- When tidying the binder itself we may tidy it's
-- specialisations; if any of these mention other binders
-- in the group we should really feed env' to them too;
-- but that seems (a) unlikely and (b) a bit tiresome.
-- So I left it out for now