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 )
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
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,
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`
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 [
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}
%************************************************************************
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
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
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) $
-- 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)
= 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 ;
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"
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}
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
| 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}
%* *
%************************************************************************
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)
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
-- 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
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}
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]
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
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)
(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
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
--- /dev/null
+%
+% (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
+
+ (bndrs, rhss) = unzip pairs
+ (env', bndrs') = mapAccumL (tidy_bndr maybe_mod) env bndrs
+ rhss' = map (tidyExpr env') rhss
+ in
+ (env', Rec (zip bndrs' rhss'))
+
+tidyExpr env (Type ty) = Type (tidyType env ty)
+tidyExpr env (Con con args) = Con con (map (tidyExpr env) args)
+tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
+tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
+
+tidyExpr env (Let b e) = Let b' (tidyExpr env' e)
+ where
+ (env', b') = tidyBind Nothing env b
+
+tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
+ where
+ (env', b') = tidyBndr env b
+
+tidyExpr env (Var v) = Var (tidyVarOcc env v)
+
+tidyExpr env (Lam b e) = Lam b' (tidyExpr env' e)
+ where
+ (env', b') = tidyBndr env b
+
+tidyAlt env (con, vs, rhs) = (con, vs', tidyExpr env' rhs)
+ where
+ (env', vs') = tidyBndrs env vs
+
+tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
+
+tidyNote env note = note
+
+tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
+ Just v' -> v'
+ Nothing -> v
+\end{code}
+
+\begin{code}
+tidy_bndr (Just mod) env id = tidyTopId mod env id
+tidy_bndr Nothing env var = tidyBndr env var
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{Tidying up a binder}
+%* *
+%************************************************************************
+
+\begin{code}
+tidyBndr :: TidyEnv -> IdOrTyVar -> (TidyEnv, IdOrTyVar)
+tidyBndr env var | isTyVar var = tidyTyVar env var
+ | otherwise = tidyId env var
+
+tidyBndrs :: TidyEnv -> [IdOrTyVar] -> (TidyEnv, [IdOrTyVar])
+tidyBndrs env vars = mapAccumL tidyBndr env vars
+
+tidyId :: TidyEnv -> Id -> (TidyEnv, Id)
+tidyId env@(tidy_env, var_env) id
+ = -- Non-top-level variables
+ let
+ -- Give the Id a fresh print-name, *and* rename its type
+ -- The SrcLoc isn't important now, though we could extract it from the Id
+ name' = mkLocalName (getUnique id) occ' noSrcLoc
+ (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
+ ty' = tidyType env (idType id)
+ id' = mkVanillaId name' ty'
+ `setIdStrictness` getIdStrictness id
+ `setIdDemandInfo` getIdDemandInfo id
+ -- NB: This throws away the IdInfo of the Id, which we
+ -- no longer need. That means we don't need to
+ -- run over it with env, nor renumber it.
+ --
+ -- The exception is strictness and demand info, which
+ -- is used to decide whether to use let or case for
+ -- function arguments and let bindings
+
+ var_env' = extendVarEnv var_env id id'
+ in
+ ((tidy_env', var_env'), id')
+
+tidyTopId :: Module -> TidyEnv -> Id -> (TidyEnv, Id)
+tidyTopId mod env@(tidy_env, var_env) id
+ = -- Top level variables
+ let
+ (tidy_env', name') | isUserExportedId id = (tidy_env, idName id)
+ | otherwise = tidyTopName mod tidy_env (idName id)
+ ty' = tidyTopType (idType id)
+ idinfo' = tidyIdInfo env (idInfo id)
+ id' = mkId name' ty' idinfo'
+ var_env' = extendVarEnv var_env id id'
+ in
+ ((tidy_env', var_env'), id')
+\end{code}
+
+\begin{code}
+-- tidyIdInfo does these things:
+-- a) tidy the specialisation info (if any)
+-- b) zap a complicated ICanSafelyBeINLINEd pragma,
+-- c) zap the unfolding
+-- The latter two are to avoid space leaks
+
+tidyIdInfo env info
+ = info4
+ where
+ rules = specInfo info
+
+ info1 | isEmptyCoreRules rules = info
+ | otherwise = info `setSpecInfo` tidyRules env rules
+
+ info2 = case inlinePragInfo info of
+ ICanSafelyBeINLINEd _ _ -> info1 `setInlinePragInfo` NoInlinePragInfo
+ other -> info1
+
+ info3 = info2 `setUnfoldingInfo` noUnfolding
+ info4 = info3 `setDemandInfo` wwLazy -- I don't understand why...
+
+tidyProtoRules :: TidyEnv -> [ProtoCoreRule] -> [ProtoCoreRule]
+tidyProtoRules env rules
+ = [ ProtoCoreRule is_local (tidyVarOcc env fn) (tidyRule env rule)
+ | ProtoCoreRule is_local fn rule <- rules
+ ]
+
+tidyRules :: TidyEnv -> CoreRules -> CoreRules
+tidyRules env (Rules rules fvs)
+ = Rules (map (tidyRule env) rules)
+ (foldVarSet tidy_set_elem emptyVarSet fvs)
+ where
+ tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
+
+tidyRule :: TidyEnv -> CoreRule -> CoreRule
+tidyRule env (Rule name vars tpl_args rhs)
+ = (Rule name vars' (map (tidyExpr env') tpl_args) (tidyExpr env' rhs))
+ where
+ (env', vars') = tidyBndrs env vars
+\end{code}
\begin{code}
module CoreUnfold (
- Unfolding(..), UnfoldingGuidance(..), -- types
+ Unfolding(..), UnfoldingGuidance, -- types
- noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
+ noUnfolding, mkUnfolding, getUnfoldingTemplate,
isEvaldUnfolding, hasUnfolding,
- smallEnoughToInline, unfoldAlways, couldBeSmallEnoughToInline,
+ couldBeSmallEnoughToInline,
certainlySmallEnoughToInline,
okToUnfoldInHiFile,
- calcUnfoldingGuidance
+ calcUnfoldingGuidance,
+
+ callSiteInline, blackListed
) where
#include "HsVersions.h"
-import {-# SOURCE #-} MagicUFs ( MagicUnfoldingFun, mkMagicUnfoldingFun )
-
-import CmdLineOpts ( opt_UnfoldingCreationThreshold,
- opt_UnfoldingUseThreshold,
- opt_UnfoldingConDiscount,
- opt_UnfoldingKeenessFactor,
- opt_UnfoldCasms, opt_PprStyle_Debug
- )
-import Constants ( uNFOLDING_CHEAP_OP_COST,
- uNFOLDING_DEAR_OP_COST,
- uNFOLDING_NOREP_LIT_COST
+import CmdLineOpts ( opt_UF_CreationThreshold,
+ opt_UF_UseThreshold,
+ opt_UF_ScrutConDiscount,
+ opt_UF_FunAppDiscount,
+ opt_UF_PrimArgDiscount,
+ opt_UF_KeenessFactor,
+ opt_UF_CheapOp, opt_UF_DearOp, opt_UF_NoRepLit,
+ opt_UnfoldCasms, opt_PprStyle_Debug,
+ opt_D_dump_inlinings
)
import CoreSyn
+import PprCore ( pprCoreExpr )
+import CoreUtils ( whnfOrBottom )
import OccurAnal ( occurAnalyseGlobalExpr )
+import BinderInfo ( )
import CoreUtils ( coreExprType, exprIsTrivial, mkFormSummary,
FormSummary(..) )
-import Id ( Id, idType, isId )
-import Const ( Con(..), isLitLitLit )
-import PrimOp ( PrimOp(..), primOpOutOfLine )
-import IdInfo ( ArityInfo(..), InlinePragInfo(..) )
+import Id ( Id, idType, idUnique, isId,
+ getIdSpecialisation, getInlinePragma, getIdUnfolding
+ )
+import VarSet
+import Const ( Con(..), isLitLitLit, isWHNFCon )
+import PrimOp ( PrimOp(..), primOpIsDupable )
+import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..) )
import TyCon ( tyConFamilySize )
-import Type ( splitAlgTyConApp_maybe )
+import Type ( splitAlgTyConApp_maybe, splitFunTy_maybe )
import Const ( isNoRepLit )
-import Unique ( Unique )
-import Util ( isIn )
+import Unique ( Unique, buildIdKey, augmentIdKey, runSTRepIdKey )
+import Maybes ( maybeToBool )
+import Bag
+import Util ( isIn, lengthExceeds )
import Outputable
\end{code}
FormSummary -- Tells whether the template is a WHNF or bottom
UnfoldingGuidance -- Tells about the *size* of the template.
CoreExpr -- Template; binder-info is correct
-
- | MagicUnfolding
- Unique -- Unique of the Id whose magic unfolding this is
- MagicUnfoldingFun
\end{code}
\begin{code}
mkUnfolding expr
= let
-- strictness mangling (depends on there being no CSE)
- ufg = calcUnfoldingGuidance opt_UnfoldingCreationThreshold expr
+ ufg = calcUnfoldingGuidance opt_UF_CreationThreshold expr
occ = occurAnalyseGlobalExpr expr
in
CoreUnfolding (mkFormSummary expr) ufg occ
-mkMagicUnfolding :: Unique -> Unfolding
-mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag)
-
getUnfoldingTemplate :: Unfolding -> CoreExpr
getUnfoldingTemplate (CoreUnfolding _ _ expr) = expr
getUnfoldingTemplate other = panic "getUnfoldingTemplate"
-- so cheap to unfold (e.g., 1#) that
-- you should do it absolutely always.
- | UnfoldIfGoodArgs Int -- if "m" type args
- Int -- and "n" value args
+ | UnfoldIfGoodArgs Int -- and "n" value args
[Int] -- Discount if the argument is evaluated.
-- (i.e., a simplification will definitely
Int -- Scrutinee discount: the discount to substract if the thing is in
-- a context (case (thing args) of ...),
-- (where there are the right number of arguments.)
-
-unfoldAlways :: UnfoldingGuidance -> Bool
-unfoldAlways UnfoldAlways = True
-unfoldAlways other = False
\end{code}
\begin{code}
instance Outputable UnfoldingGuidance where
- ppr UnfoldAlways = ptext SLIT("_ALWAYS_")
- ppr (UnfoldIfGoodArgs t v cs size discount)
- = hsep [ptext SLIT("_IF_ARGS_"), int t, int v,
+ ppr UnfoldAlways = ptext SLIT("ALWAYS")
+ ppr UnfoldNever = ptext SLIT("NEVER")
+ ppr (UnfoldIfGoodArgs v cs size discount)
+ = hsep [ptext SLIT("IF_ARGS"), int v,
if null cs -- always print *something*
then char 'X'
else hcat (map (text . show) cs),
= UnfoldAlways
| otherwise
- = case collectTyAndValBinders expr of { (ty_binders, val_binders, body) ->
+ = case collectBinders expr of { (binders, body) ->
+ let
+ val_binders = filter isId binders
+ in
case (sizeExpr bOMB_OUT_SIZE val_binders body) of
TooBig -> UnfoldNever
SizeIs size cased_args scrut_discount
-> UnfoldIfGoodArgs
- (length ty_binders)
(length val_binders)
(map discount_for val_binders)
(I# size)
where
discount_for b
| num_cases == 0 = 0
- | otherwise
- = if is_data
- then tyConFamilySize tycon * num_cases
- else num_cases -- prim cases are pretty cheap
-
- where
- (is_data, tycon)
- = case (splitAlgTyConApp_maybe (idType b)) of
- Nothing -> (False, panic "discount")
- Just (tc,_,_) -> (True, tc)
- num_cases = length (filter (==b) cased_args)
+ | is_fun_ty = num_cases * opt_UF_FunAppDiscount
+ | is_data_ty = num_cases * tyConFamilySize tycon * opt_UF_ScrutConDiscount
+ | otherwise = num_cases * opt_UF_PrimArgDiscount
+ where
+ num_cases = foldlBag (\n b' -> if b==b' then n+1 else n) 0 cased_args
+ -- Count occurrences of b in cased_args
+ arg_ty = idType b
+ is_fun_ty = maybeToBool (splitFunTy_maybe arg_ty)
+ (is_data_ty, tycon) = case (splitAlgTyConApp_maybe (idType b)) of
+ Nothing -> (False, panic "discount")
+ Just (tc,_,_) -> (True, tc)
}
\end{code}
sizeExpr (I# bOMB_OUT_SIZE) args expr
= size_up expr
where
- size_up (Type t) = sizeZero -- Types cost nothing
- size_up (Note _ body) = size_up body -- Notes cost nothing
- size_up (Var v) = sizeOne
- size_up (App fun arg) = size_up fun `addSize` size_up arg
+ size_up (Type t) = sizeZero -- Types cost nothing
+ size_up (Var v) = sizeOne
+
+ size_up (Note InlineMe _) = sizeTwo -- The idea is that this is one more
+ -- than the size of the "call" (i.e. 1)
+ -- We want to reply "no" to noSizeIncrease
+ -- for a bare reference (i.e. applied to no args)
+ -- to an INLINE thing
+
+ size_up (Note _ body) = size_up body -- Notes cost nothing
+
+ size_up (App fun (Type t)) = size_up fun
+ size_up (App fun arg) = size_up_app fun `addSize` size_up arg
size_up (Con con args) = foldr (addSize . size_up)
- (size_up_con con (valArgCount args))
+ (size_up_con con args)
args
size_up (Lam b e) | isId b = size_up e `addSizeN` 1
Just (tc,_,_) -> tyConFamilySize tc
------------
+ -- A function application with at least one value argument
+ -- so if the function is an argument give it an arg-discount
+ size_up_app (App fun arg) = size_up_app fun `addSize` size_up arg
+ size_up_app fun = arg_discount fun `addSize` size_up fun
+
+ ------------
size_up_alt (con, bndrs, rhs) = size_up rhs
-- Don't charge for args, so that wrappers look cheap
------------
- size_up_con (Literal lit) nv | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
- | otherwise = sizeOne
+ size_up_con (Literal lit) args | isNoRepLit lit = sizeN opt_UF_NoRepLit
+ | otherwise = sizeOne
- size_up_con (DataCon dc) n_val_args = conSizeN n_val_args
+ size_up_con (DataCon dc) args = conSizeN (valArgCount args)
- size_up_con (PrimOp op) nv = sizeN op_cost
+ size_up_con (PrimOp op) args = foldr addSize (sizeN op_cost) (map arg_discount args)
+ -- Give an arg-discount if a primop is applies to
+ -- one of the function's arguments
where
- op_cost = if primOpOutOfLine op
- then uNFOLDING_DEAR_OP_COST
- -- these *tend* to be more expensive;
- -- number chosen to avoid unfolding (HACK)
- else uNFOLDING_CHEAP_OP_COST
+ op_cost | primOpIsDupable op = opt_UF_CheapOp
+ | otherwise = opt_UF_DearOp
------------
- -- We want to record if we're case'ing an argument
+ -- We want to record if we're case'ing, or applying, an argument
arg_discount (Var v) | v `is_elem` args = scrutArg v
arg_discount other = sizeZero
where
n_tot = n1 +# n2
d_tot = d1 +# d2
- xys = xs ++ ys
-
-
+ xys = xs `unionBags` ys
\end{code}
Code for manipulating sizes
data ExprSize = TooBig
| SizeIs Int# -- Size found
- [Id] -- Arguments cased herein
+ (Bag Id) -- Arguments cased herein
Int# -- Size to subtract if result is scrutinised
-- by a case expression
-sizeZero = SizeIs 0# [] 0#
-sizeOne = SizeIs 1# [] 0#
-sizeN (I# n) = SizeIs n [] 0#
-conSizeN (I# n) = SizeIs 0# [] n -- We don't count 1 for the constructor because we're
- -- quite keen to get constructors into the open
-scrutArg v = SizeIs 0# [v] 0#
+sizeZero = SizeIs 0# emptyBag 0#
+sizeOne = SizeIs 1# emptyBag 0#
+sizeTwo = SizeIs 2# emptyBag 0#
+sizeN (I# n) = SizeIs n emptyBag 0#
+conSizeN (I# n) = SizeIs 1# emptyBag (n +# 1#)
+ -- Treat constructors as size 1, that unfoldAlways responsds 'False'
+ -- when asked about 'x' when x is bound to (C 3#).
+ -- This avoids gratuitous 'ticks' when x itself appears as an
+ -- atomic constructor argument.
+
+scrutArg v = SizeIs 0# (unitBag v) 0#
nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
nukeScrutDiscount TooBig = TooBig
\end{code}
+
%************************************************************************
%* *
\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
is more accurate (see @sizeExpr@ above for how this discount size
is computed).
-\begin{code}
-smallEnoughToInline :: Id -- The function (trace msg only)
- -> [Bool] -- Evaluated-ness of value arguments
- -- ** May be infinite in don't care cases **
- -- see couldBeSmallEnoughToInline etc
- -> Bool -- Result is scrutinised
- -> UnfoldingGuidance
- -> Bool -- True => unfold it
-
-smallEnoughToInline _ _ _ UnfoldAlways = True
-smallEnoughToInline _ _ _ UnfoldNever = False
-smallEnoughToInline id arg_evals result_is_scruted
- (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount)
- | fun_with_no_args
- = False
-
- | (size - discount) > opt_UnfoldingUseThreshold
- = if opt_PprStyle_Debug then
- pprTrace " too big:" stuff False
- else
- False
-
- | otherwise -- All right!
- = if opt_PprStyle_Debug then
- pprTrace " small enough:" stuff True
- else
- True
-
- where
- stuff = braces (ppr id <+> ppr (take 10 arg_evals) <+> ppr result_is_scruted <+>
- ppr size <+> ppr discount)
-
- fun_with_no_args = n_vals_wanted > 0 && null arg_evals
- -- A *function* with *no* value args => don't unfold
- -- Otherwise it's ok to try
-
- -- We multiple the raw discounts (args_discount and result_discount)
- -- ty opt_UnfoldingKeenessFactor because the former have to do with
- -- *size* whereas the discounts imply that there's some extra
- -- *efficiency* to be gained (e.g. beta reductions, case reductions)
- -- by inlining.
-
- -- we also discount 1 for each argument passed, because these will
- -- reduce with the lambdas in the function (we count 1 for a lambda
- -- in size_up).
-
- -- NB: we never take the length of arg_evals because it might be infinite
- discount :: Int
- discount = length (take n_vals_wanted arg_evals) +
- round (opt_UnfoldingKeenessFactor *
- fromInt (arg_discount + result_discount))
-
- arg_discount = sum (zipWith mk_arg_discount discount_vec arg_evals)
- result_discount = mk_result_discount (drop n_vals_wanted arg_evals)
-
- mk_arg_discount no_of_constrs is_evald
- | is_evald = no_of_constrs * opt_UnfoldingConDiscount
- | otherwise = 0
-
- mk_result_discount extra_args
- | not (null extra_args) || result_is_scruted = scrut_discount -- Over-applied, or case scrut
- | otherwise = 0
-\end{code}
-
We use this one to avoid exporting inlinings that we ``couldn't possibly
use'' on the other side. Can be overridden w/ flaggery.
Just the same as smallEnoughToInline, except that it has no actual arguments.
\begin{code}
-couldBeSmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
-couldBeSmallEnoughToInline id guidance = smallEnoughToInline id (repeat True) True guidance
-
-certainlySmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
-certainlySmallEnoughToInline id guidance = smallEnoughToInline id (repeat False) False guidance
+couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool
+couldBeSmallEnoughToInline UnfoldNever = False
+couldBeSmallEnoughToInline other = True
+
+certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool
+certainlySmallEnoughToInline UnfoldNever = False
+certainlySmallEnoughToInline UnfoldAlways = True
+certainlySmallEnoughToInline (UnfoldIfGoodArgs _ _ size _) = size <= opt_UF_UseThreshold
\end{code}
@okToUnfoldInHifile@ is used when emitting unfolding info into an interface
okToUnfoldPrimOp (CCallOp _ is_casm _ _) = not is_casm
okToUnfoldPrimOp _ = True
\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{callSiteInline}
+%* *
+%************************************************************************
+
+This is the key function. It decides whether to inline a variable at a call site
+
+callSiteInline is used at call sites, so it is a bit more generous.
+It's a very important function that embodies lots of heuristics.
+A non-WHNF can be inlined if it doesn't occur inside a lambda,
+and occurs exactly once or
+ occurs once in each branch of a case and is small
+
+If the thing is in WHNF, there's no danger of duplicating work,
+so we can inline if it occurs once, or is small
+
+\begin{code}
+callSiteInline :: Bool -- True <=> the Id is black listed
+ -> Bool -- 'inline' note at call site
+ -> Id -- The Id
+ -> [CoreExpr] -- Arguments
+ -> Bool -- True <=> continuation is interesting
+ -> Maybe CoreExpr -- Unfolding, if any
+
+
+callSiteInline black_listed inline_call id args interesting_cont
+ = case getIdUnfolding id of {
+ NoUnfolding -> Nothing ;
+ OtherCon _ -> Nothing ;
+ CoreUnfolding form guidance unf_template ->
+
+ let
+ result | yes_or_no = Just unf_template
+ | otherwise = Nothing
+
+ inline_prag = getInlinePragma id
+ arg_infos = map interestingArg val_args
+ val_args = filter isValArg args
+ whnf = whnfOrBottom form
+
+ yes_or_no =
+ case inline_prag of
+ IAmDead -> pprTrace "callSiteInline: dead" (ppr id) False
+ IMustNotBeINLINEd -> False
+ IAmALoopBreaker -> False
+ IMustBeINLINEd -> True -- Overrides absolutely everything, including the black list
+ ICanSafelyBeINLINEd in_lam one_br -> consider in_lam one_br
+ NoInlinePragInfo -> consider InsideLam False
+
+ consider in_lam one_branch
+ | black_listed = False
+ | inline_call = True
+ | one_branch -- Be very keen to inline something if this is its unique occurrence; that
+ -- gives a good chance of eliminating the original binding for the thing.
+ -- The only time we hold back is when substituting inside a lambda;
+ -- then if the context is totally uninteresting (not applied, not scrutinised)
+ -- there is no point in substituting because it might just increase allocation.
+ = case in_lam of
+ NotInsideLam -> True
+ InsideLam -> whnf && (not (null args) || interesting_cont)
+
+ | otherwise -- Occurs (textually) more than once, so look at its size
+ = case guidance of
+ UnfoldAlways -> True
+ UnfoldNever -> False
+ UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount
+ | enough_args && size <= (n_vals_wanted + 1)
+ -- No size increase
+ -- Size of call is n_vals_wanted (+1 for the function)
+ -> case in_lam of
+ NotInsideLam -> True
+ InsideLam -> whnf
+
+ | not (or arg_infos || really_interesting_cont)
+ -- If it occurs more than once, there must be something interesting
+ -- about some argument, or the result, to make it worth inlining
+ -> False
+
+ | otherwise
+ -> case in_lam of
+ NotInsideLam -> small_enough
+ InsideLam -> whnf && small_enough
+
+ where
+ n_args = length arg_infos
+ enough_args = n_args >= n_vals_wanted
+ really_interesting_cont | n_args < n_vals_wanted = False -- Too few args
+ | n_args == n_vals_wanted = interesting_cont
+ | otherwise = True -- Extra args
+ -- This rather elaborate defn for really_interesting_cont is important
+ -- Consider an I# = INLINE (\x -> I# {x})
+ -- The unfolding guidance deems it to have size 2, and no arguments.
+ -- So in an application (I# y) we must take the extra arg 'y' as
+ -- evidene of an interesting context!
+
+ small_enough = (size - discount) <= opt_UF_UseThreshold
+ discount = computeDiscount n_vals_wanted arg_discounts res_discount
+ arg_infos really_interesting_cont
+
+
+ in
+#ifdef DEBUG
+ if opt_D_dump_inlinings then
+ pprTrace "Considering inlining"
+ (ppr id <+> vcat [text "black listed" <+> ppr black_listed,
+ text "inline prag:" <+> ppr inline_prag,
+ text "arg infos" <+> ppr arg_infos,
+ text "interesting continuation" <+> ppr interesting_cont,
+ text "whnf" <+> ppr whnf,
+ text "guidance" <+> ppr guidance,
+ text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO",
+ if yes_or_no then
+ text "Unfolding =" <+> pprCoreExpr unf_template
+ else empty])
+ result
+ else
+#endif
+ result
+ }
+
+-- An argument is interesting if it has *some* structure
+-- We are here trying to avoid unfolding a function that
+-- is applied only to variables that have no unfolding
+-- (i.e. they are probably lambda bound): f x y z
+-- There is little point in inlining f here.
+interestingArg (Type _) = False
+interestingArg (App fn (Type _)) = interestingArg fn
+interestingArg (Var v) = hasUnfolding (getIdUnfolding v)
+interestingArg other = True
+
+
+computeDiscount :: Int -> [Int] -> Int -> [Bool] -> Bool -> Int
+computeDiscount n_vals_wanted arg_discounts res_discount arg_infos result_used
+ -- We multiple the raw discounts (args_discount and result_discount)
+ -- ty opt_UnfoldingKeenessFactor because the former have to do with
+ -- *size* whereas the discounts imply that there's some extra
+ -- *efficiency* to be gained (e.g. beta reductions, case reductions)
+ -- by inlining.
+
+ -- we also discount 1 for each argument passed, because these will
+ -- reduce with the lambdas in the function (we count 1 for a lambda
+ -- in size_up).
+ = length (take n_vals_wanted arg_infos) +
+ -- Discount of 1 for each arg supplied, because the
+ -- result replaces the call
+ round (opt_UF_KeenessFactor *
+ fromInt (arg_discount + result_discount))
+ where
+ arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos)
+
+ mk_arg_discount discount is_evald | is_evald = discount
+ | otherwise = 0
+
+ -- Don't give a result discount unless there are enough args
+ result_discount | result_used = res_discount -- Over-applied, or case scrut
+ | otherwise = 0
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Black-listing}
+%* *
+%************************************************************************
+
+Inlining is controlled by the "Inline phase" number, which is set
+by the per-simplification-pass '-finline-phase' flag.
+
+For optimisation we use phase 1,2 and nothing (i.e. no -finline-phase flag)
+in that order. The meanings of these are determined by the @blackListed@ function
+here.
+
+\begin{code}
+blackListed :: IdSet -- Used in transformation rules
+ -> Maybe Int -- Inline phase
+ -> Id -> Bool -- True <=> blacklisted
+
+-- The blackListed function sees whether a variable should *not* be
+-- inlined because of the inline phase we are in. This is the sole
+-- place that the inline phase number is looked at.
+
+-- Phase 0: used for 'no inlinings please'
+blackListed rule_vars (Just 0)
+ = \v -> True
+
+-- Phase 1: don't inline any rule-y things or things with specialisations
+blackListed rule_vars (Just 1)
+ = \v -> let v_uniq = idUnique v
+ in v `elemVarSet` rule_vars
+ || not (isEmptyCoreRules (getIdSpecialisation v))
+ || v_uniq == runSTRepIdKey
+
+-- Phase 2: allow build/augment to inline, and specialisations
+blackListed rule_vars (Just 2)
+ = \v -> let v_uniq = idUnique v
+ in (v `elemVarSet` rule_vars && not (v_uniq == buildIdKey ||
+ v_uniq == augmentIdKey))
+ || v_uniq == runSTRepIdKey
+
+-- Otherwise just go for it
+blackListed rule_vars phase
+ = \v -> False
+\end{code}
+
+
+SLPJ 95/04: Why @runST@ must be inlined very late:
+\begin{verbatim}
+f x =
+ runST ( \ s -> let
+ (a, s') = newArray# 100 [] s
+ (_, s'') = fill_in_array_or_something a x s'
+ in
+ freezeArray# a s'' )
+\end{verbatim}
+If we inline @runST@, we'll get:
+\begin{verbatim}
+f x = let
+ (a, s') = newArray# 100 [] realWorld#{-NB-}
+ (_, s'') = fill_in_array_or_something a x s'
+ in
+ freezeArray# a s''
+\end{verbatim}
+And now the @newArray#@ binding can be floated to become a CAF, which
+is totally and utterly wrong:
+\begin{verbatim}
+f = let
+ (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
+ in
+ \ x ->
+ let (_, s'') = fill_in_array_or_something a x s' in
+ freezeArray# a s''
+\end{verbatim}
+All calls to @f@ will share a {\em single} array!
+
+Yet we do want to inline runST sometime, so we can avoid
+needless code. Solution: black list it until the last moment.
+
\begin{code}
module CoreUtils (
- IdSubst, SubstCoreExpr(..),
-
- coreExprType, coreAltsType, exprFreeVars, exprSomeFreeVars,
+ coreExprType, coreAltsType,
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap,
- FormSummary(..), mkFormSummary, whnfOrBottom,
- cheapEqExpr,
-
- substExpr, substId, substIds,
- idSpecVars, idFreeVars
+ exprOkForSpeculation,
+ FormSummary(..), mkFormSummary, whnfOrBottom, exprArity,
+ cheapEqExpr, eqExpr, applyTypeToArgs
) where
#include "HsVersions.h"
-import {-# SOURCE #-} CoreUnfold ( noUnfolding, hasUnfolding )
import CoreSyn
-import PprCore () -- Instances only
+import PprCore ( pprCoreExpr )
import Var ( IdOrTyVar, isId, isTyVar )
import VarSet
import VarEnv
import Name ( isLocallyDefined )
-import Const ( Con(..), isWHNFCon, conIsTrivial, conIsCheap )
+import Const ( Con, isWHNFCon, conIsTrivial, conIsCheap, conIsDupable,
+ conType, conOkForSpeculation, conStrictness
+ )
import Id ( Id, idType, setIdType, idUnique, idAppIsBottom,
- getIdArity, idFreeTyVars,
+ getIdArity,
getIdSpecialisation, setIdSpecialisation,
getInlinePragma, setInlinePragma,
getIdUnfolding, setIdUnfolding, idInfo
)
import IdInfo ( arityLowerBound, InlinePragInfo(..), lbvarInfo, LBVarInfo(..) )
-import SpecEnv ( emptySpecEnv, specEnvToList, isEmptySpecEnv )
-import CostCentre ( CostCentre )
-import Const ( Con, conType )
-import Type ( Type, TyVarSubst, mkFunTy, mkForAllTy,
- splitFunTy_maybe, applyTys, tyVarsOfType, tyVarsOfTypes,
+import Type ( Type, mkFunTy, mkForAllTy,
+ splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes,
isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
- fullSubstTy, substTyVar )
+ tidyTyVar, applyTys, isUnLiftedType
+ )
+import Demand ( isPrim, isLazy )
import Unique ( buildIdKey, augmentIdKey )
import Util ( zipWithEqual, mapAccumL )
import Outputable
%************************************************************************
%* *
-\subsection{Substitutions}
-%* *
-%************************************************************************
-
-\begin{code}
-type IdSubst = IdEnv SubstCoreExpr -- Maps Ids to SubstCoreExpr
-
-data SubstCoreExpr
- = Done CoreExpr -- No more substitution needed
- | SubstMe CoreExpr TyVarSubst IdSubst -- A suspended substitution
-\end{code}
-
-%************************************************************************
-%* *
\subsection{Find the type of a Core atom/expression}
%* *
%************************************************************************
= case collectArgs e of
(fun, args) -> applyTypeToArgs e (coreExprType fun) args
-coreExprType other = pprTrace "coreExprType" (ppr other) alphaTy
+coreExprType other = pprTrace "coreExprType" (pprCoreExpr other) alphaTy
coreAltsType :: [CoreAlt] -> Type
coreAltsType ((_,_,rhs) : _) = coreExprType rhs
\end{code}
\begin{code}
--- The "e" argument is just for debugging
-
+-- The first argument is just for debugging
+applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
applyTypeToArgs e op_ty [] = op_ty
applyTypeToArgs e op_ty (Type ty : args)
applyTypeToArgs e op_ty (other_arg : args)
= case (splitFunTy_maybe op_ty) of
Just (_, res_ty) -> applyTypeToArgs e res_ty args
- Nothing -> pprPanic "applyTypeToArgs" (ppr e)
+ Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
\end{code}
happy to duplicate; simple variables and constants,
and type applications.
-@exprIsDupable@ is true of expressions that can be duplicated at a modest
- cost in space, but without duplicating any work.
-
-
@exprIsBottom@ is true of expressions that are guaranteed to diverge
\end{code}
+@exprIsDupable@ is true of expressions that can be duplicated at a modest
+ cost in space. This will only happen in different case
+ branches, so there's no issue about duplicating work.
+ Its only purpose is to avoid fruitless let-binding
+ and then inlining of case join points
+
+
\begin{code}
exprIsDupable (Type _) = True
-exprIsDupable (Con con args) = conIsCheap con &&
+exprIsDupable (Con con args) = conIsDupable con &&
all exprIsDupable args &&
valArgCount args <= dupAppSize
exprIsDupable (Note _ e) = exprIsDupable e
exprIsDupable expr = case collectArgs expr of
- (Var v, args) -> n_val_args == 0 ||
- (n_val_args < fun_arity &&
- all exprIsDupable args &&
- n_val_args <= dupAppSize)
- where
- n_val_args = valArgCount args
- fun_arity = arityLowerBound (getIdArity v)
-
- _ -> False
+ (Var f, args) -> valArgCount args <= dupAppSize
+ other -> False
dupAppSize :: Int
dupAppSize = 4 -- Size of application we are prepared to duplicate
exprIsCheap other_expr -- look for manifest partial application
= case collectArgs other_expr of
+ (f, args) -> isPap f (valArgCount args) && all exprIsCheap args
+\end{code}
- (Var f, args) | idAppIsBottom f (length args)
- -> True -- Application of a function which
+\begin{code}
+isPap :: CoreExpr -- Function
+ -> Int -- Number of value args
+ -> Bool
+isPap (Var f) n_val_args
+ = idAppIsBottom f n_val_args
+ -- Application of a function which
-- always gives bottom; we treat this as
-- a WHNF, because it certainly doesn't
-- need to be shared!
- (Var f, args) ->
- let
- num_val_args = valArgCount args
- in
- num_val_args == 0 || -- Just a type application of
- -- a variable (f t1 t2 t3)
- -- counts as WHNF
- num_val_args < arityLowerBound (getIdArity f)
+ || n_val_args == 0 -- Just a type application of
+ -- a variable (f t1 t2 t3)
+ -- counts as WHNF
+
+ || n_val_args < arityLowerBound (getIdArity f)
+
+isPap fun n_val_args = False
+\end{code}
+
+exprOkForSpeculation returns True of an UNLIFTED-TYPE expression that it is safe
+to evaluate even if normal order eval might not evaluate the expression
+at all. E.G.
+ let x = case y# +# 1# of { r# -> I# r# }
+ in E
+==>
+ case y# +# 1# of { r# ->
+ let x = I# r#
+ in E
+ }
- _ -> False
+We can only do this if the (y+1) is ok for speculation: it has no
+side effects, and can't diverge or raise an exception.
+
+\begin{code}
+exprOkForSpeculation :: CoreExpr -> Bool
+exprOkForSpeculation (Var v) = True -- Unlifted type => already evaluated
+
+exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
+exprOkForSpeculation (Let (NonRec b r) e) = isUnLiftedType (idType b) &&
+ exprOkForSpeculation r &&
+ exprOkForSpeculation e
+exprOkForSpeculation (Let (Rec _) _) = False
+exprOkForSpeculation (Case _ _ _) = False -- Conservative
+exprOkForSpeculation (App _ _) = False
+
+exprOkForSpeculation (Con con args)
+ = conOkForSpeculation con &&
+ and (zipWith ok (filter isValArg args) (fst (conStrictness con)))
+ where
+ ok arg demand | isLazy demand = True
+ | isPrim demand = exprOkForSpeculation arg
+ | otherwise = False
+
+exprOkForSpeculation other = panic "exprOkForSpeculation"
+ -- Lam, Type
\end{code}
_ -> False
\end{code}
+\begin{code}
+exprArity :: CoreExpr -> Int -- How many value lambdas are at the top
+exprArity (Lam b e) | isTyVar b = exprArity e
+ | otherwise = 1 + exprArity e
+exprArity other = 0
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Equality}
+%* *
+%************************************************************************
+
@cheapEqExpr@ is a cheap equality test which bales out fast!
True => definitely equal
False => may or may not be equal
\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
-
- * 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
-
-exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting
- -> CoreExpr
- -> IdOrTyVarSet
-exprSomeFreeVars fv_cand e = expr_fvs e 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
-
-oneVar :: IdOrTyVar -> FV
-oneVar var fv_cand in_scope
- | keep_it fv_cand in_scope var = unitVarSet var
- | otherwise = emptyVarSet
-
-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 (idFreeVars 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)
+eqExpr :: CoreExpr -> CoreExpr -> Bool
+ -- Works ok at more general type, but only needed at CoreExpr
+eqExpr e1 e2
+ = eq emptyVarEnv e1 e2
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
+ -- The "env" maps variables in e1 to variables in ty2
+ -- So when comparing lambdas etc,
+ -- we in effect substitute v2 for v1 in e1 before continuing
+ eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
+ Just v1' -> v1' == v2
+ Nothing -> v1 == v2
+
+ eq env (Con c1 es1) (Con c2 es2) = c1 == c2 && eq_list env es1 es2
+ eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
+ eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
+ eq env (Let (NonRec v1 r1) e1)
+ (Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
+ eq env (Let (Rec ps1) e1)
+ (Let (Rec ps2) e2) = length ps1 == length ps2 &&
+ and (zipWith eq_rhs ps1 ps2) &&
+ eq env' e1 e2
+ where
+ env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
+ eq_rhs (_,r1) (_,r2) = eq env' r1 r2
+ eq env (Case e1 v1 a1)
+ (Case e2 v2 a2) = eq env e1 e2 &&
+ length a1 == length a2 &&
+ and (zipWith (eq_alt env') a1 a2)
+ where
+ env' = extendVarEnv env v1 v2
+
+ eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
+ eq env (Type t1) (Type t2) = t1 == t2
+ eq env e1 e2 = False
+
+ eq_list env [] [] = True
+ eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
+ eq_list env es1 es2 = False
+
+ eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
+ eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
+
+ eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
+ eq_note env (Coerce f1 t1) (Coerce f2 t2) = f1==f2 && t1==t2
+ eq_note env InlineCall InlineCall = True
+ eq_note env other1 other2 = False
\end{code}
-
-Given an Id, idSpecVars returns all its specialisations.
-We extract these from its SpecEnv.
-This is used by the occurrence analyser and free-var finder;
-we regard an Id's specialisations as free in the Id's definition.
-
-\begin{code}
-idSpecVars :: Id -> IdOrTyVarSet
-idSpecVars id
- = foldr (unionVarSet . spec_item_fvs)
- emptyVarSet
- (specEnvToList (getIdSpecialisation id))
- where
- spec_item_fvs (tyvars, tys, rhs) = foldl delVarSet
- (tyVarsOfTypes tys `unionVarSet` exprFreeVars rhs)
- tyvars
-
-idFreeVars :: Id -> IdOrTyVarSet
-idFreeVars id = idSpecVars id `unionVarSet` idFreeTyVars id
-\end{code}
-
-
-%************************************************************************
-%* *
-\section{Substitution}
-%* *
-%************************************************************************
-
-This expression substituter deals correctly with name capture, much
-like Type.substTy.
-
-BUT NOTE that substExpr silently discards the
- unfolding, and
- spec env
-IdInfo attached to any binders in the expression. It's quite
-tricky to do them 'right' in the case of mutually recursive bindings,
-and so far has proved unnecessary.
-
-\begin{code}
-substExpr :: TyVarSubst -> IdSubst -- Substitution
- -> IdOrTyVarSet -- Superset of in-scope
- -> CoreExpr
- -> CoreExpr
-
-substExpr te ve in_scope expr = subst_expr (te, ve, in_scope) expr
-
-subst_expr env@(te, ve, in_scope) expr
- = go expr
- where
- go (Var v) = case lookupVarEnv ve v of
- Just (Done e')
- -> e'
-
- Just (SubstMe e' te' ve')
- -> subst_expr (te', ve', in_scope) e'
-
- Nothing -> case lookupVarSet in_scope v of
- Just v' -> Var v'
- Nothing -> Var v
- -- NB: we look up in the in_scope set because the variable
- -- there may have more info. In particular, when substExpr
- -- is called from the simplifier, the type inside the *occurrences*
- -- of a variable may not be right; we should replace it with the
- -- binder, from the in_scope set.
-
- go (Type ty) = Type (go_ty ty)
- go (Con con args) = Con con (map go args)
- go (App fun arg) = App (go fun) (go arg)
- go (Note note e) = Note (go_note note) (go e)
-
- go (Lam bndr body) = Lam bndr' (subst_expr env' body)
- where
- (env', bndr') = go_bndr env bndr
-
- go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (subst_expr env' body)
- where
- (env', bndr') = go_bndr env bndr
-
- go (Let (Rec pairs) body) = Let (Rec pairs') (subst_expr env' body)
- where
- (ve', in_scope', _, bndrs')
- = substIds clone_fn te ve in_scope undefined (map fst pairs)
- env' = (te, ve', in_scope')
- pairs' = bndrs' `zip` rhss'
- rhss' = map (subst_expr env' . snd) pairs
-
- go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt env') alts)
- where
- (env', bndr') = go_bndr env bndr
-
- go_alt env (con, bndrs, rhs) = (con, bndrs', subst_expr env' rhs)
- where
- (env', bndrs') = mapAccumL go_bndr env bndrs
-
- go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
- go_note note = note
-
- go_ty ty = fullSubstTy te in_scope ty
-
- go_bndr (te, ve, in_scope) bndr
- | isTyVar bndr
- = case substTyVar te in_scope bndr of
- (te', in_scope', bndr') -> ((te', ve, in_scope'), bndr')
-
- | otherwise
- = case substId clone_fn te ve in_scope undefined bndr of
- (ve', in_scope', _, bndr') -> ((te, ve', in_scope'), bndr')
-
-
- clone_fn in_scope _ bndr
- | bndr `elemVarSet` in_scope = Just (uniqAway in_scope bndr, undefined)
- | otherwise = Nothing
-
-\end{code}
-
-Substituting in binders is a rather tricky part of the whole compiler.
-
-\begin{code}
-substIds :: (IdOrTyVarSet -> us -> Id -> Maybe (us, Id)) -- Cloner
- -> TyVarSubst -> IdSubst -> IdOrTyVarSet -- Usual stuff
- -> us -- Unique supply
- -> [Id]
- -> (IdSubst, IdOrTyVarSet, -- New id_subst, in_scope
- us, -- New unique supply
- [Id])
-
-substIds clone_fn ty_subst id_subst in_scope us []
- = (id_subst, in_scope, us, [])
-
-substIds clone_fn ty_subst id_subst in_scope us (id:ids)
- = case (substId clone_fn ty_subst id_subst in_scope us id) of {
- (id_subst', in_scope', us', id') ->
-
- case (substIds clone_fn ty_subst id_subst' in_scope' us' ids) of {
- (id_subst'', in_scope'', us'', ids') ->
-
- (id_subst'', in_scope'', us'', id':ids')
- }}
-
-
-substId :: (IdOrTyVarSet -> us -> Id -> Maybe (us, Id)) -- Cloner
- -> TyVarSubst -> IdSubst -> IdOrTyVarSet -- Usual stuff
- -> us -- Unique supply
- -> Id
- -> (IdSubst, IdOrTyVarSet, -- New id_subst, in_scope
- us, -- New unique supply
- Id)
-
--- Returns an Id with empty unfolding and spec-env.
--- It's up to the caller to sort these out.
-
-substId clone_fn
- ty_subst id_subst in_scope
- us id
- | old_id_will_do
- -- No need to clone, but we *must* zap any current substitution
- -- for the variable. For example:
- -- (\x.e) with id_subst = [x |-> e']
- -- Here we must simply zap the substitution for x
- = (delVarEnv id_subst id, extendVarSet in_scope id, us, id)
-
- | otherwise
- = (extendVarEnv id_subst id (Done (Var new_id)),
- extendVarSet in_scope new_id,
- new_us,
- new_id)
- where
- id_ty = idType id
- old_id_will_do = old1 && old2 && old3 && {-old4 && -}not cloned
-
- -- id1 has its type zapped
- (id1,old1) | isEmptyVarEnv ty_subst
- || isEmptyVarSet (tyVarsOfType id_ty) = (id, True)
- | otherwise = (setIdType id ty', False)
-
- ty' = fullSubstTy ty_subst in_scope id_ty
-
- -- id2 has its SpecEnv zapped
- -- It's filled in later by Simplify.simplPrags
- (id2,old2) | isEmptySpecEnv spec_env = (id1, True)
- | otherwise = (setIdSpecialisation id1 emptySpecEnv, False)
- spec_env = getIdSpecialisation id
-
- -- id3 has its Unfolding zapped
- -- This is very important; occasionally a let-bound binder is used
- -- as a binder in some lambda, in which case its unfolding is utterly
- -- bogus. Also the unfolding uses old binders so if we left it we'd
- -- have to substitute it. Much better simply to give the Id a new
- -- unfolding each time, which is what the simplifier does.
- (id3,old3) | hasUnfolding (getIdUnfolding id) = (id2 `setIdUnfolding` noUnfolding, False)
- | otherwise = (id2, True)
-
- -- new_id is cloned if necessary
- (new_us, new_id, cloned) = case clone_fn in_scope us id3 of
- Nothing -> (us, id3, False)
- Just (us', id') -> (us', id', True)
-
- -- new_id_bndr has its Inline info neutered. We must forget about whether it
- -- was marked safe-to-inline, because that isn't necessarily true in
- -- the simplified expression. We do this for the *binder* which will
- -- be used at the binding site, but we *dont* do it for new_id, which
- -- is put into the in_scope env. Why not? Because the in_scope env
- -- carries down the occurrence information to usage sites!
- --
- -- Net result: post-simplification, occurrences may have over-optimistic
- -- occurrence info, but binders won't.
-{- (new_id_bndr, old4)
- = case getInlinePragma id of
- ICanSafelyBeINLINEd _ _ -> (setInlinePragma new_id NoInlinePragInfo, False)
- other -> (new_id, True)
--}
-\end{code}
-
-
-
-
-
\begin{code}
module PprCore (
- pprCoreExpr, pprIfaceUnfolding,
- pprCoreBinding, pprCoreBindings, pprIdBndr
+ pprCoreExpr, pprParendExpr, pprIfaceUnfolding,
+ pprCoreBinding, pprCoreBindings, pprIdBndr,
+ pprCoreRules, pprCoreRule
) where
#include "HsVersions.h"
import Id ( idType, idInfo, getInlinePragma, getIdDemandInfo, Id )
import Var ( isTyVar )
import IdInfo ( IdInfo,
- arityInfo, ppArityInfo,
+ arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
demandInfo, updateInfo, ppUpdateInfo, specInfo,
strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
cprInfo, ppCprInfo
import Const ( Con(..), DataCon )
import DataCon ( isTupleCon, isUnboxedTupleCon )
import PprType ( pprParendType, pprTyVarBndr )
-import SpecEnv ( specEnvToList )
import PprEnv
import Outputable
\end{code}
pprCoreBindings :: [CoreBind] -> SDoc
pprCoreBinding :: CoreBind -> SDoc
pprCoreExpr :: CoreExpr -> SDoc
+pprParendExpr :: CoreExpr -> SDoc
pprCoreBindings = pprTopBinds pprCoreEnv
pprCoreBinding = pprTopBind pprCoreEnv
pprCoreExpr = ppr_expr pprCoreEnv
+pprParendExpr = ppr_parend_expr pprCoreEnv
pprCoreEnv = initCoreEnv pprCoreBinder
\end{code}
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
pprIfaceUnfolding :: CoreExpr -> SDoc
-pprIfaceUnfolding = ppr_expr pprIfaceEnv
+pprIfaceUnfolding = ppr_parend_expr pprIfaceEnv
+ -- Notice that it's parenthesised
+
+pprIfaceArg = ppr_arg pprIfaceEnv
pprIfaceEnv = initCoreEnv pprIfaceBinder
\end{code}
#ifdef DEBUG
ppr_expr pe (Note (Coerce to_ty from_ty) expr)
- = \ sty ->
+ = getPprStyle $ \ sty ->
if debugStyle sty && not (ifaceStyle sty) then
- sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty, pTy pe from_ty],
- ppr_parend_expr pe expr] sty
+ sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty],
+ ppr_parend_expr pe expr]
else
sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
- ppr_parend_expr pe expr] sty
+ ppr_parend_expr pe expr]
#else
ppr_expr pe (Note (Coerce to_ty from_ty) expr)
- = sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
+ = sep [sep [ptext SLIT("__coerce"), nest 4 pTy pe to_ty],
ppr_parend_expr pe expr]
#endif
ppr_expr pe (Note InlineCall expr)
- = ptext SLIT("__inline") <+> ppr_parend_expr pe expr
+ = ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr
+
+ppr_expr pe (Note InlineMe expr)
+ = ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
ppr_expr pe (Note (TermUsg u) expr)
= \ sty ->
ppIdInfo :: IdInfo -> SDoc
ppIdInfo info
= hsep [
+ ppFlavourInfo (flavourInfo info),
ppArityInfo a,
ppUpdateInfo u,
ppStrictnessInfo s,
ppr d,
ppCafInfo c,
ppCprInfo m,
- ppSpecInfo p
+ pprIfaceCoreRules p
-- Inline pragma printed out with all binders; see PprCore.pprIdBndr
]
where
p = specInfo info
\end{code}
+
\begin{code}
-ppSpecInfo spec_env
- = vcat (map pp_item (specEnvToList spec_env))
+pprCoreRules :: Id -> CoreRules -> SDoc
+pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (Just var)) rules)
+
+pprIfaceCoreRules :: CoreRules -> SDoc
+pprIfaceCoreRules (Rules rules _) = vcat (map (pprCoreRule Nothing) rules)
+
+pprCoreRule :: Maybe Id -> CoreRule -> SDoc
+pprCoreRule maybe_fn (Rule name tpl_vars tpl_args rhs)
+ = doubleQuotes (ptext name) <+>
+ sep [
+ ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
+ nest 4 (pp_fn <+> sep (map pprIfaceArg tpl_args)),
+ nest 4 (ptext SLIT("=") <+> pprIfaceUnfolding rhs)
+ ]
where
- pp_item (tyvars, tys, rhs) = hsep [ptext SLIT("__P"),
- hsep (map pprParendType tys),
- ptext SLIT("->"),
- ppr head]
- where
- (_, body) = collectBinders rhs
- (head, _) = collectArgs body
+ pp_fn = case maybe_fn of
+ Just id -> ppr id
+ Nothing -> empty -- Interface file
\end{code}
-
--- /dev/null
+_interface_ Subst 1
+_exports_ Subst Subst mkTyVarSubst substTy ;
+_declarations_
+1 data Subst;
+1 mkTyVarSubst _:_ [Var.TyVar] -> [Type.Type] -> Subst ;;
+1 substTy _:_ Subst -> Type.Type -> Type.Type ;;
+
--- /dev/null
+__interface Subst 1 0 where
+__export Subst Subst mkTyVarSubst substTy ;
+1 data Subst;
+1 mkTyVarSubst :: [Var.TyVar] -> [Type.Type] -> Subst ;
+1 substTy :: Subst -> Type.Type -> Type.Type ;
+
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[CoreUtils]{Utility functions on @Core@ syntax}
+
+\begin{code}
+module Subst (
+ -- In-scope set
+ InScopeSet, emptyInScopeSet,
+ lookupInScope, setInScope, extendInScope, extendInScopes, isInScope,
+
+ -- Substitution stuff
+ Subst, TyVarSubst, IdSubst,
+ emptySubst, mkSubst, substEnv, substInScope,
+ lookupSubst, isEmptySubst, extendSubst, extendSubstList,
+ zapSubstEnv, setSubstEnv,
+
+ bindSubst, unBindSubst, bindSubstList, unBindSubstList,
+
+ -- Binders
+ substBndr, substBndrs, substTyVar, substId, substIds,
+ substAndCloneId, substAndCloneIds,
+
+ -- Type stuff
+ mkTyVarSubst, mkTopTyVarSubst,
+ substTy, substTheta,
+
+ -- Expression stuff
+ substExpr, substRules
+ ) where
+
+#include "HsVersions.h"
+
+
+import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr,
+ CoreRules(..), CoreRule(..), emptyCoreRules, isEmptyCoreRules
+ )
+import CoreUnfold ( hasUnfolding, noUnfolding )
+import CoreFVs ( exprFreeVars )
+import Type ( Type(..), ThetaType, TyNote(..),
+ tyVarsOfType, tyVarsOfTypes, mkAppTy
+ )
+import VarSet
+import VarEnv
+import Var ( setVarUnique, isId )
+import Id ( idType, setIdType )
+import IdInfo ( zapFragileIdInfo )
+import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply )
+import Var ( Var, IdOrTyVar, Id, TyVar, isTyVar, maybeModifyIdInfo )
+import Outputable
+import Util ( mapAccumL, foldl2, seqList, ($!) )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Substitutions}
+%* *
+%************************************************************************
+
+\begin{code}
+type InScopeSet = VarSet
+
+data Subst = Subst InScopeSet -- In scope
+ SubstEnv -- Substitution itself
+ -- INVARIANT 1: The in-scope set is a superset
+ -- of the free vars of the range of the substitution
+ -- that might possibly clash with locally-bound variables
+ -- in the thing being substituted in.
+ -- This is what lets us deal with name capture properly
+ -- It's a hard invariant to check...
+ -- There are various ways of causing it to happen:
+ -- - arrange that the in-scope set really is all the things in scope
+ -- - arrange that it's the free vars of the range of the substitution
+ -- - make it empty because all the free vars of the subst are fresh,
+ -- and hence can't possibly clash.a
+ --
+ -- INVARIANT 2: No variable is both in scope and in the domain of the substitution
+ -- Equivalently, the substitution is idempotent
+ --
+
+type IdSubst = Subst
+\end{code}
+
+\begin{code}
+emptyInScopeSet :: InScopeSet
+emptyInScopeSet = emptyVarSet
+\end{code}
+
+
+
+\begin{code}
+isEmptySubst :: Subst -> Bool
+isEmptySubst (Subst _ env) = isEmptySubstEnv env
+
+emptySubst :: Subst
+emptySubst = Subst emptyVarSet emptySubstEnv
+
+mkSubst :: InScopeSet -> SubstEnv -> Subst
+mkSubst in_scope env = Subst in_scope env
+
+substEnv :: Subst -> SubstEnv
+substEnv (Subst _ env) = env
+
+substInScope :: Subst -> InScopeSet
+substInScope (Subst in_scope _) = in_scope
+
+zapSubstEnv :: Subst -> Subst
+zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
+
+extendSubst :: Subst -> Var -> SubstResult -> Subst
+extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r)
+
+extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst
+extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r)
+
+lookupSubst :: Subst -> Var -> Maybe SubstResult
+lookupSubst (Subst _ env) v = lookupSubstEnv env v
+
+lookupInScope :: Subst -> Var -> Maybe Var
+lookupInScope (Subst in_scope _) v = lookupVarSet in_scope v
+
+isInScope :: Var -> Subst -> Bool
+isInScope v (Subst in_scope _) = v `elemVarSet` in_scope
+
+extendInScope :: Subst -> Var -> Subst
+extendInScope (Subst in_scope env) v = Subst (extendVarSet in_scope v) env
+
+extendInScopes :: Subst -> [Var] -> Subst
+extendInScopes (Subst in_scope env) vs = Subst (foldl extendVarSet in_scope vs) env
+
+-------------------------------
+bindSubst :: Subst -> Var -> Var -> Subst
+-- Extend with a substitution, v1 -> Var v2
+-- and extend the in-scopes with v2
+bindSubst (Subst in_scope env) old_bndr new_bndr
+ = Subst (in_scope `extendVarSet` new_bndr)
+ (extendSubstEnv env old_bndr subst_result)
+ where
+ subst_result | isId old_bndr = DoneEx (Var new_bndr)
+ | otherwise = DoneTy (TyVarTy new_bndr)
+
+unBindSubst :: Subst -> Var -> Var -> Subst
+-- Reverse the effect of bindSubst
+-- If old_bndr was already in the substitution, this doesn't quite work
+unBindSubst (Subst in_scope env) old_bndr new_bndr
+ = Subst (in_scope `delVarSet` new_bndr) (delSubstEnv env old_bndr)
+
+-- And the "List" forms
+bindSubstList :: Subst -> [Var] -> [Var] -> Subst
+bindSubstList subst old_bndrs new_bndrs
+ = foldl2 bindSubst subst old_bndrs new_bndrs
+
+unBindSubstList :: Subst -> [Var] -> [Var] -> Subst
+unBindSubstList subst old_bndrs new_bndrs
+ = foldl2 unBindSubst subst old_bndrs new_bndrs
+
+
+-------------------------------
+setInScope :: Subst -- Take env part from here
+ -> InScopeSet
+ -> Subst
+setInScope (Subst in_scope1 env1) in_scope2
+ = ASSERT( in_scope1 `subVarSet` in_scope1 )
+ Subst in_scope2 env1
+
+setSubstEnv :: Subst -- Take in-scope part from here
+ -> SubstEnv -- ... and env part from here
+ -> Subst
+setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Type substitution}
+%* *
+%************************************************************************
+
+\begin{code}
+type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
+ -- (We could have a variant of Subst, but it doesn't seem worth it.)
+
+-- mkTyVarSubst generates the in-scope set from
+-- the types given; but it's just a thunk so with a bit of luck
+-- it'll never be evaluated
+mkTyVarSubst :: [TyVar] -> [Type] -> Subst
+mkTyVarSubst tyvars tys = Subst (tyVarsOfTypes tys) (zip_ty_env tyvars tys emptySubstEnv)
+
+-- mkTopTyVarSubst is called when doing top-level substitutions.
+-- Here we expect that the free vars of the range of the
+-- substitution will be empty.
+mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
+mkTopTyVarSubst tyvars tys = Subst emptyVarSet (zip_ty_env tyvars tys emptySubstEnv)
+
+zip_ty_env [] [] env = env
+zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
+\end{code}
+
+substTy works with general Substs, so that it can be called from substExpr too.
+
+\begin{code}
+substTy :: Subst -> Type -> Type
+substTy subst ty | isEmptySubst subst = ty
+ | otherwise = subst_ty subst ty
+
+substTheta :: TyVarSubst -> ThetaType -> ThetaType
+substTheta subst theta
+ | isEmptySubst subst = theta
+ | otherwise = [(clas, map (subst_ty subst) tys) | (clas, tys) <- theta]
+
+subst_ty subst ty
+ = go ty
+ where
+ go (TyConApp tc tys) = let args = map go tys
+ in args `seqList` TyConApp tc args
+ go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
+ go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
+ go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
+ go (NoteTy (UsgNote usg) ty2) = NoteTy $! UsgNote usg $! go ty2 -- Keep usage annot
+ go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
+ go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
+ Nothing -> ty
+ Just (DoneTy ty') -> ty'
+
+ go (ForAllTy tv ty) = case substTyVar subst tv of
+ (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
+\end{code}
+
+Here is where we invent a new binder if necessary.
+
+\begin{code}
+substTyVar :: Subst -> TyVar -> (Subst, TyVar)
+substTyVar subst@(Subst in_scope env) old_var
+ | old_var == new_var -- No need to clone
+ -- But we *must* zap any current substitution for the variable.
+ -- For example:
+ -- (\x.e) with id_subst = [x |-> e']
+ -- Here we must simply zap the substitution for x
+ --
+ -- The new_id isn't cloned, but it may have a different type
+ -- etc, so we must return it, not the old id
+ = (Subst (in_scope `extendVarSet` new_var)
+ (delSubstEnv env old_var),
+ new_var)
+
+ | otherwise -- The new binder is in scope so
+ -- we'd better rename it away from the in-scope variables
+ -- Extending the substitution to do this renaming also
+ -- has the (correct) effect of discarding any existing
+ -- substitution for that variable
+ = (Subst (in_scope `extendVarSet` new_var)
+ (extendSubstEnv env old_var (DoneTy (TyVarTy new_var))),
+ new_var)
+ where
+ new_var = uniqAway in_scope old_var
+ -- The uniqAway part makes sure the new variable is not already in scope
+\end{code}
+
+
+%************************************************************************
+%* *
+\section{Expression substitution}
+%* *
+%************************************************************************
+
+This expression substituter deals correctly with name capture.
+
+BUT NOTE that substExpr silently discards the
+ unfolding, and
+ spec env
+IdInfo attached to any binders in the expression. It's quite
+tricky to do them 'right' in the case of mutually recursive bindings,
+and so far has proved unnecessary.
+
+\begin{code}
+substExpr :: Subst -> CoreExpr -> CoreExpr
+substExpr subst expr | isEmptySubst subst = expr
+ | otherwise = subst_expr subst expr
+
+subst_expr subst expr
+ = go expr
+ where
+ go (Var v) = case lookupSubst subst v of
+ Just (DoneEx e') -> e'
+ Just (ContEx env' e') -> subst_expr (setSubstEnv subst env') e'
+ Nothing -> case lookupInScope subst v of
+ Just v' -> Var v'
+ Nothing -> Var v
+ -- NB: we look up in the in_scope set because the variable
+ -- there may have more info. In particular, when substExpr
+ -- is called from the simplifier, the type inside the *occurrences*
+ -- of a variable may not be right; we should replace it with the
+ -- binder, from the in_scope set.
+
+ go (Type ty) = Type (go_ty ty)
+ go (Con con args) = Con con (map go args)
+ go (App fun arg) = App (go fun) (go arg)
+ go (Note note e) = Note (go_note note) (go e)
+
+ go (Lam bndr body) = Lam bndr' (subst_expr subst' body)
+ where
+ (subst', bndr') = substBndr subst bndr
+
+ go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (subst_expr subst' body)
+ where
+ (subst', bndr') = substBndr subst bndr
+
+ go (Let (Rec pairs) body) = Let (Rec pairs') (subst_expr subst' body)
+ where
+ (subst', bndrs') = substBndrs subst (map fst pairs)
+ pairs' = bndrs' `zip` rhss'
+ rhss' = map (subst_expr subst' . snd) pairs
+
+ go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt subst') alts)
+ where
+ (subst', bndr') = substBndr subst bndr
+
+ go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr subst' rhs)
+ where
+ (subst', bndrs') = substBndrs subst bndrs
+
+ go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
+ go_note note = note
+
+ go_ty ty = substTy subst ty
+
+\end{code}
+
+Substituting in binders is a rather tricky part of the whole compiler.
+
+When we hit a binder we may need to
+ (a) apply the the type envt (if non-empty) to its type
+ (b) apply the type envt and id envt to its SpecEnv (if it has one)
+ (c) give it a new unique to avoid name clashes
+
+\begin{code}
+substBndr :: Subst -> IdOrTyVar -> (Subst, IdOrTyVar)
+substBndr subst bndr
+ | isTyVar bndr = substTyVar subst bndr
+ | otherwise = substId subst bndr
+
+substBndrs :: Subst -> [IdOrTyVar] -> (Subst, [IdOrTyVar])
+substBndrs subst bndrs = mapAccumL substBndr subst bndrs
+
+
+substIds :: Subst -> [Id] -> (Subst, [Id])
+substIds subst bndrs = mapAccumL substId subst bndrs
+
+substId :: Subst -> Id -> (Subst, Id)
+
+-- Returns an Id with empty unfolding and spec-env.
+-- It's up to the caller to sort these out.
+
+substId subst@(Subst in_scope env) old_id
+ = (Subst (in_scope `extendVarSet` new_id)
+ (extendSubstEnv env old_id (DoneEx (Var new_id))),
+ new_id)
+ where
+ id_ty = idType old_id
+
+ -- id1 has its type zapped
+ id1 | noTypeSubst env
+ || isEmptyVarSet (tyVarsOfType id_ty) = old_id
+ -- The tyVarsOfType is cheaper than it looks
+ -- because we cache the free tyvars of the type
+ -- in a Note in the id's type itself
+ | otherwise = setIdType old_id (substTy subst id_ty)
+
+ -- id2 has its fragile IdInfo zapped
+ id2 = maybeModifyIdInfo zapFragileIdInfo id1
+
+ -- new_id is cloned if necessary
+ new_id = uniqAway in_scope id2
+\end{code}
+
+Now a variant that unconditionally allocates a new unique.
+
+\begin{code}
+substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, UniqSupply, [Id])
+substAndCloneIds subst us [] = (subst, us, [])
+substAndCloneIds subst us (b:bs) = case substAndCloneId subst us b of { (subst1, us1, b') ->
+ case substAndCloneIds subst1 us1 bs of { (subst2, us2, bs') ->
+ (subst2, us2, (b':bs')) }}
+
+substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, UniqSupply, Id)
+substAndCloneId subst@(Subst in_scope env) us old_id
+ = (Subst (in_scope `extendVarSet` new_id)
+ (extendSubstEnv env old_id (DoneEx (Var new_id))),
+ new_us,
+ new_id)
+ where
+ id_ty = idType old_id
+ id1 | noTypeSubst env || isEmptyVarSet (tyVarsOfType id_ty) = old_id
+ | otherwise = setIdType old_id (substTy subst id_ty)
+
+ id2 = maybeModifyIdInfo zapFragileIdInfo id1
+ new_id = setVarUnique id2 (uniqFromSupply us1)
+ (us1,new_us) = splitUniqSupply us
+\end{code}
+
+
+%************************************************************************
+%* *
+\section{Rule substitution}
+%* *
+%************************************************************************
+
+\begin{code}
+substRules :: Subst -> CoreRules -> CoreRules
+substRules subst (Rules rules rhs_fvs)
+ = Rules (map do_subst rules)
+ (subst_fvs (substEnv subst) rhs_fvs)
+ where
+ do_subst (Rule name tpl_vars lhs_args rhs)
+ = Rule name tpl_vars'
+ (map (substExpr subst') lhs_args)
+ (substExpr subst' rhs)
+ where
+ (subst', tpl_vars') = substBndrs subst tpl_vars
+
+ subst_fvs se fvs
+ = foldVarSet (unionVarSet . subst_fv) emptyVarSet rhs_fvs
+ where
+ subst_fv fv = case lookupSubstEnv se fv of
+ Nothing -> unitVarSet fv
+ Just (DoneEx expr) -> exprFreeVars expr
+ Just (DoneTy ty) -> tyVarsOfType ty
+ Just (ContEx se' expr) -> subst_fvs se' (exprFreeVars expr)
+\end{code}
#include "HsVersions.h"
import CmdLineOpts ( opt_D_dump_ds )
-import HsSyn ( MonoBinds )
-import TcHsSyn ( TypecheckedMonoBinds, TypecheckedForeignDecl )
+import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) )
+import HsCore ( UfRuleBody(..) )
+import TcHsSyn ( TypecheckedMonoBinds, TypecheckedForeignDecl, TypecheckedRuleDecl )
+import TcModule ( TcResults(..) )
import CoreSyn
+import Rules ( ProtoCoreRule(..), pprProtoCoreRule )
+import Subst ( substExpr, mkSubst )
import DsMonad
+import DsExpr ( dsExpr )
import DsBinds ( dsMonoBinds, AutoScc(..) )
import DsForeign ( dsForeigns )
import DsUtils
import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
-- depends on DsExpr.hi-boot.
import Module ( Module, moduleString )
+import Id ( Id )
+import Name ( isLocallyDefined )
+import VarEnv
+import VarSet
import Bag ( isEmptyBag, unionBags )
import CmdLineOpts ( opt_SccGroup, opt_SccProfilingOn )
import CoreLint ( beginPass, endPass )
import UniqSupply ( splitUniqSupply, UniqSupply )
\end{code}
+%************************************************************************
+%* *
+%* The main function: deSugar
+%* *
+%************************************************************************
+
The only trick here is to get the @DsMonad@ stuff off to a good
start.
\begin{code}
-deSugar :: UniqSupply -- name supply
- -> ValueEnv -- value env
- -> Module -- module name
- -> TypecheckedMonoBinds
- -> [TypecheckedForeignDecl]
- -> IO ([CoreBind], SDoc, SDoc) -- output
-
-deSugar us global_val_env mod_name all_binds fo_decls = do
+deSugar :: Module
+ -> UniqSupply
+ -> TcResults
+ -> IO ([CoreBind], [ProtoCoreRule], SDoc, SDoc)
+
+deSugar mod_name us (TcResults {tc_env = global_val_env,
+ tc_binds = all_binds,
+ tc_rules = rules,
+ tc_fords = fo_decls})
+ = do
beginPass "Desugar"
-- Do desugaring
- let (core_prs, ds_warns1) = initDs us1 global_val_env module_and_group
- (dsMonoBinds auto_scc all_binds [])
- auto_scc | opt_SccProfilingOn = TopLevel
- | otherwise = NoSccs
- ds_binds' = [Rec core_prs]
-
- ((fi_binds, fe_binds, h_code, c_code), ds_warns2) =
- initDs us3 global_val_env module_and_group (dsForeigns mod_name fo_decls)
-
- ds_binds = fi_binds ++ ds_binds' ++ fe_binds
-
- ds_warns = ds_warns1 `unionBags` ds_warns2
+ let (result, ds_warns) = initDs us global_val_env module_and_group
+ (dsProgram mod_name all_binds rules fo_decls)
+ (ds_binds, ds_rules, _, _) = result
-- Display any warnings
doIfSet (not (isEmptyBag ds_warns))
-- Lint result if necessary
endPass "Desugar" opt_D_dump_ds ds_binds
- return (ds_binds, h_code, c_code)
- where
- (us1, us2) = splitUniqSupply us
- (us3, us4) = splitUniqSupply us2
+ doIfSet opt_D_dump_ds (printDump (ppr_ds_rules ds_rules))
+
+ return result
+ where
module_and_group = (mod_name, grp_name)
grp_name = case opt_SccGroup of
Just xx -> _PK_ xx
Nothing -> _PK_ (moduleString mod_name) -- default: module name
+dsProgram mod_name all_binds rules fo_decls
+ = dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs ->
+ dsForeigns mod_name fo_decls `thenDs` \ (fi_binds, fe_binds, h_code, c_code) ->
+ mapDs dsRule rules `thenDs` \ rules' ->
+ let
+ ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds
+ in
+ returnDs (ds_binds, rules', h_code, c_code)
+ where
+ auto_scc | opt_SccProfilingOn = TopLevel
+ | otherwise = NoSccs
+
+ppr_ds_rules [] = empty
+ppr_ds_rules rules
+ = text "" $$ text "-------------- DESUGARED RULES -----------------" $$
+ vcat (map pprProtoCoreRule rules)
+\end{code}
+
+
+%************************************************************************
+%* *
+%* Desugaring transformation rules
+%* *
+%************************************************************************
+
+\begin{code}
+dsRule :: TypecheckedRuleDecl -> DsM ProtoCoreRule
+dsRule (IfaceRuleDecl fn (CoreRuleBody name all_vars args rhs) loc)
+ = returnDs (ProtoCoreRule False {- non-local -} fn
+ (Rule name all_vars args rhs))
+
+dsRule (RuleDecl name sig_tvs vars lhs rhs loc)
+ = putSrcLocDs loc $
+ ds_lhs all_vars lhs `thenDs` \ (fn, args) ->
+ dsExpr rhs `thenDs` \ core_rhs ->
+ returnDs (ProtoCoreRule True {- local -} fn
+ (Rule name all_vars args core_rhs))
+ where
+ all_vars = sig_tvs ++ [var | RuleBndr var <- vars]
+
+ds_lhs all_vars lhs
+ = let
+ (dict_binds, body) = case lhs of
+ (HsLet (MonoBind dict_binds _ _) body) -> (dict_binds, body)
+ other -> (EmptyMonoBinds, lhs)
+ in
+ ds_dict_binds dict_binds `thenDs` \ dict_binds' ->
+ dsExpr body `thenDs` \ body' ->
+
+ -- Substitute the dict bindings eagerly,
+ -- and take the body apart into a (f args) form
+ let
+ subst_env = mkSubstEnv [id | (id,rhs) <- dict_binds']
+ [ContEx subst_env rhs | (id,rhs) <- dict_binds']
+ -- Note recursion here... substitution won't terminate
+ -- if there is genuine recursion... which there isn't
+
+ subst = mkSubst (mkVarSet all_vars) subst_env
+ body'' = substExpr subst body'
+ in
+
+ -- Now unpack the resulting body
+ let
+ pair = case collectArgs body'' of
+ (Var fn, args) -> (fn, args)
+ other -> pprPanic "dsRule" (ppr lhs)
+ in
+ returnDs pair
+
+ds_dict_binds EmptyMonoBinds = returnDs []
+ds_dict_binds (AndMonoBinds b1 b2) = ds_dict_binds b1 `thenDs` \ env1 ->
+ ds_dict_binds b2 `thenDs` \ env2 ->
+ returnDs (env1 ++ env2)
+ds_dict_binds (VarMonoBind id rhs) = dsExpr rhs `thenDs` \ rhs' ->
+ returnDs [(id,rhs')]
\end{code}
opt_AutoSccsOnExportedToplevs, opt_AutoSccsOnDicts
)
import CostCentre ( CostCentre, mkAutoCC, IsCafCC(..) )
-import Id ( idType, Id )
+import Id ( idType, idName, isUserExportedId, Id )
+import NameSet
import VarEnv
-import Name ( isExported )
-import Type ( mkTyVarTy, isDictTy, substTy )
+import VarSet
+import Type ( mkTyVarTy, isDictTy )
+import Subst ( mkTyVarSubst, substTy )
import TysWiredIn ( voidTy )
import Outputable
-- Common case: one exported variable
-- All non-recursive bindings come through this way
-dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] binds) rest
+dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds) rest
= ASSERT( all (`elem` tyvars) all_tyvars )
dsMonoBinds (addSccs auto_scc exps) binds [] `thenDs` \ core_prs ->
let
-- Always treat the binds as recursive, because the typechecker
-- makes rather mixed-up dictionary bindings
core_binds = [Rec core_prs]
- global' = (global, mkLams tyvars $ mkLams dicts $
- mkLets core_binds (Var local))
+ global' = (global, mkInline (idName global `elemNameSet` inlines) $
+ mkLams tyvars $ mkLams dicts $
+ mkDsLets core_binds (Var local))
in
-
returnDs (global' : rest)
- -- Another Common special case: no type or dictionary abstraction
-dsMonoBinds auto_scc (AbsBinds [] [] exports binds) rest
- = let exports' = [(global, Var local) | (_, global, local) <- exports] in
- dsMonoBinds (addSccs auto_scc exports) binds (exports' ++ rest)
+ -- Another common special case: no type or dictionary abstraction
+dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest
+ = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
+ let
+ exports' = [(global, Var local) | (_, global, local) <- exports]
+ in
+ returnDs (addLocalInlines exports inlines core_prs ++ exports' ++ rest)
-dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports binds) rest
+dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
= dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
let
- core_binds = [Rec core_prs]
+ core_binds = [Rec (addLocalInlines exports inlines core_prs)]
tup_expr = mkTupleExpr locals
tup_ty = coreExprType tup_expr
poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
- mkLets core_binds tup_expr
+ mkDsLets core_binds tup_expr
locals = [local | (_, _, local) <- exports]
local_tys = map idType locals
in
mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
| otherwise = voidTy
ty_args = map mk_ty_arg all_tyvars
- env = all_tyvars `zipVarEnv` ty_args
+ env = mkTyVarSubst all_tyvars ty_args
in
zipWithDs mk_bind exports [0..] `thenDs` \ export_binds ->
-- don't scc (auto-)annotate the tuple itself.
%************************************************************************
%* *
+\subsection{Adding inline pragmas}
+%* *
+%************************************************************************
+
+\begin{code}
+mkInline :: Bool -> CoreExpr -> CoreExpr
+mkInline True body = Note InlineMe body
+mkInline False body = body
+
+addLocalInlines :: [(a, Id, Id)] -> NameSet -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
+addLocalInlines exports inlines pairs
+ = [(bndr, mkInline (bndr `elemVarSet` local_inlines) rhs) | (bndr,rhs) <- pairs]
+ where
+ local_inlines = mkVarSet [l | (_,g,l) <- exports, idName g `elemNameSet` inlines]
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection[addAutoScc]{Adding automatic sccs}
%* *
%************************************************************************
addSccs TopLevel exports
= TopLevelAddSccs (\id -> case [ exp | (_,exp,loc) <- exports, loc == id ] of
(exp:_) | opt_AutoSccsOnAllToplevs ||
- (isExported exp &&
+ (isUserExportedId exp &&
opt_AutoSccsOnExportedToplevs)
-> Just exp
_ -> Nothing)
import DsGRHSs ( dsGuarded )
import DsCCall ( dsCCall )
import DsListComp ( dsListComp )
-import DsUtils ( mkErrorAppDs )
+import DsUtils ( mkErrorAppDs, mkDsLets, mkConsExpr, mkNilExpr )
import Match ( matchWrapper, matchSimply )
import CoreUtils ( coreExprType )
import Const ( Con(..) )
import DataCon ( DataCon, dataConId, dataConTyCon, dataConArgTys, dataConFieldLabels )
import Const ( mkMachInt, Literal(..), mkStrLit )
-import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID )
+import PrelInfo ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID )
import TyCon ( isNewTyCon )
import DataCon ( isExistentialDataCon )
import Type ( splitFunTys, mkTyConApp,
splitAppTy, isUnLiftedType, Type
)
import TysWiredIn ( tupleCon, unboxedTupleCon,
- consDataCon, listTyCon, mkListTy,
+ listTyCon, mkListTy,
charDataCon, charTy, stringTy
)
import BasicTypes ( RecFlag(..) )
dsLet b1 body'
-- Special case for bindings which bind unlifted variables
-dsLet (MonoBind (AbsBinds [] [] binder_triples (PatMonoBind pat grhss loc)) sigs is_rec) body
+-- Silently ignore INLINE pragmas...
+dsLet (MonoBind (AbsBinds [] [] binder_triples inlines (PatMonoBind pat grhss loc)) sigs is_rec) body
| or [isUnLiftedType (idType g) | (_, g, l) <- binder_triples]
= ASSERT (case is_rec of {NonRecursive -> True; other -> False})
putSrcLocDs loc $
= dsMonoBinds NoSccs binds [] `thenDs` \ prs ->
case is_rec of
Recursive -> returnDs (Let (Rec prs) body)
- NonRecursive -> returnDs (foldr mk_let body prs)
- where
- mk_let (bndr,rhs) body = Let (NonRec bndr rhs) body
+ NonRecursive -> returnDs (mkDsLets [NonRec b r | (b,r) <- prs] body)
\end{code}
%************************************************************************
= let
the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_ s))]
the_nil = mkNilExpr charTy
- the_cons = mkConApp consDataCon [Type charTy, the_char, the_nil]
+ the_cons = mkConsExpr charTy the_char the_nil
in
returnDs the_cons
dsExpr (OpApp e1 op _ e2)
= dsExpr op `thenDs` \ core_op ->
-- for the type of y, we need the type of op's 2nd argument
- let
- (x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op)
- in
dsExpr e1 `thenDs` \ x_core ->
dsExpr e2 `thenDs` \ y_core ->
returnDs (mkApps core_op [x_core, y_core])
go (x:xs) = dsExpr x `thenDs` \ core_x ->
go xs `thenDs` \ core_xs ->
ASSERT( isNotUsgTy ty )
- returnDs (mkConApp consDataCon [Type ty, core_x, core_xs])
+ returnDs (mkConsExpr ty core_x core_xs)
dsExpr (ExplicitTuple expr_list boxed)
= mapDs dsExpr expr_list `thenDs` \ core_exprs ->
import CoreUtils ( coreExprType )
import Const ( Con(..), mkMachInt )
import DataCon ( DataCon, dataConId )
-import Id ( Id, idType, idName, mkWildId, mkUserId )
+import Id ( Id, idType, idName, mkWildId, mkVanillaId )
import Const ( Literal(..) )
import Module ( Module )
import Name ( mkGlobalName, nameModule, nameOccName, getOccString,
mkForeignExportOcc, isLocalName,
NamedThing(..), Provenance(..), ExportFlag(..)
)
-import PrelVals ( realWorldPrimId )
-import PrelInfo ( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME )
+import PrelInfo ( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME, realWorldPrimId )
import Type ( splitAlgTyConApp_maybe,
splitTyConApp_maybe, splitFunTys, splitForAllTys,
Type, mkFunTys, mkForAllTys, mkTyConApp,
[Type io_res_ty, Var ds]
fo_rhs = mkLams (tvs ++ args)
- (Let (NonRec ds (the_body::CoreExpr)) io_app)
+ (mkDsLet (NonRec ds (the_body::CoreExpr)) io_app)
in
returnDs (NonRec nm fo_rhs)
\end{code}
getUniqueDs `thenDs` \ uniq ->
getSrcLocDs `thenDs` \ src_loc ->
let
- f_helper_glob = mkUserId helper_name helper_ty
+ f_helper_glob = mkVanillaId helper_name helper_ty
where
name = idName i
mod
import DsMonad
import DsUtils
-import PrelVals ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
+import PrelInfo ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
import Unique ( otherwiseIdKey, trueDataConKey, Uniquable(..) )
import Outputable
\end{code}
collectTypedMonoBinders (CoreMonoBind v _) = [v]
collectTypedMonoBinders (AndMonoBinds bs1 bs2)
= collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2
-collectTypedMonoBinders (AbsBinds _ _ exports _)
+collectTypedMonoBinders (AbsBinds _ _ exports _ _)
= [global | (_, global, local) <- exports]
collectTypedPatBinders :: TypecheckedPat -> [Id]
import CmdLineOpts ( opt_FoldrBuildOn )
import CoreUtils ( coreExprType )
+import Id ( idType )
import Var ( Id, TyVar )
import Const ( Con(..) )
-import PrelInfo ( foldrId )
+import PrelInfo ( foldrId, buildId )
import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, Type )
import TysPrim ( alphaTyVar, alphaTy )
import TysWiredIn ( nilDataCon, consDataCon, listTyCon )
dsListComp quals elt_ty
| not opt_FoldrBuildOn -- Be boring
- = deListComp quals nil_expr
+ = deListComp quals (mkNilExpr elt_ty)
| otherwise -- foldr/build lives!
= newTyVarsDs [alphaTyVar] `thenDs` \ [n_tyvar] ->
let
- alpha_to_alpha = alphaTy `mkFunTy` alphaTy
-
n_ty = mkTyVarTy n_tyvar
c_ty = mkFunTys [elt_ty, n_ty] n_ty
- g_ty = mkForAllTy alphaTyVar (
- (elt_ty `mkFunTy` alpha_to_alpha)
- `mkFunTy`
- alpha_to_alpha
- )
in
- newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] ->
+ newSysLocalsDs [c_ty,n_ty] `thenDs` \ [c, n] ->
- dfListComp c_ty c
- n_ty n
- quals `thenDs` \ result ->
+ dfListComp c n quals `thenDs` \ result ->
- returnDs (mkBuild elt_ty n_tyvar c n g result)
- where
- nil_expr = mkNilExpr elt_ty
+ returnDs (Var buildId `App` Type elt_ty
+ `App` mkLams [n_tyvar, c, n] result)
\end{code}
%************************************************************************
is the TE translation scheme. Note that we carry around the @L@ list
already desugared. @dsListComp@ does the top TE rule mentioned above.
-deListComp :: [TypecheckedStmt]
- -> CoreExpr -> CoreExpr -- Cons and nil resp; can be copied freely
- -> DsM CoreExpr
-
-deListComp [ReturnStmt expr] cons nil
- = dsExpr expr `thenDs` \ expr' ->
- returnDs (mkApps cons [expr', nil])
-
-deListComp (GuardStmt guard locn : quals) cons nil
- = dsExpr guard `thenDs` \ guard' ->
- deListComp quals cons nil `thenDs` \ rest' ->
- returnDs (mkIfThenElse guard' rest' nil)
-
-deListComp (LetStmt binds : quals) cons nil
- = deListComp quals cons nil `thenDs` \ rest' ->
- dsLet binds rest'
-
-deListComp (BindStmt pat list locn : quals) cons nil
- = dsExpr list `thenDs` \ list' ->
- let
- pat_ty = outPatType pat
- nil_ty = coreExprType nil
- in
- newSysLocalsDs [pat_ty, nil_ty] `thenDs` \ [x,ys] ->
-
- dsListComp quals cons (Var ys) `thenDs` \ rest ->
- matchSimply (Var x) ListCompMatch pat
- rest (Var ys) `thenDs` \ core_match ->
- bindNonRecDs (mkLams [x,ys] fn_body) $ \ fn ->
- dsListExpr list (Var fn) nil
-
-
-data FExpr = FEOther CoreExpr -- Default case
- | FECons -- cons
- | FEConsComposedWith CoreExpr -- (cons . e)
- | FENil -- nil
-
-feComposeWith FECons g
- = returnDs (FEConsComposedWith g)
-
-feComposeWith (FEOther f) g
- = composeWith f f `thenDs` \ h ->
- returnDs (FEOther h)
-
-feComposeWith (FEConsComposedWith f) g
- = composeWith f f `thenDs` \ h ->
- returnDs (FEConsComposedWith h)
-
-
-composeWith f g
- = newSysLocalDs arg_ty `thenDs` \ x ->
- returnDs (Lam x (App e (App f (Var x))))
- where
- arg_ty = case splitFunTy_maybe (coreExprType g) of
- Just (arg_ty,_) -> arg_ty
- other -> panic "feComposeWith"
-
-deListExpr :: TypecheckedHsExpr
- -> FExpr -> FExpr -- Cons and nil expressions
- -> DsM CoreExpr
-
-deListExpr cons nil (HsDoOut ListComp stmts _ _ _ result_ty src_loc)
- = deListComp stmts cons nil
-
-deListExpr cons nil (HsVar map, _, [f,xs])
- | goodInst var mapIdKey = dsExpr f `thenDs` \ f' ->
- feComposeWith cons f' `thenDs` \ cons' ->
- in
- deListExpr xs cons' nil
-
-
-data HsExprForm = GoodForm What [Type] [TypecheckedHsExpr]
- | BadForm
-
-data What = HsMap | HsConcat | HsFilter | HsZip | HsFoldr
-
-analyseListProducer (HsVar v) ty_args val_args
- | good_inst mapIdKey 2 = GoodForm HsMap ty_args val_args
- | good_inst concatIdKey 1 = GoodForm HsConcat ty_args val_args
- | good_inst filterIdKey 2 = GoodForm HsFilter ty_args val_args
- | good_id zipIdKey 2 = GoodForm HsZip ty_args val_args
- | otherwise =
- where
- good_inst key arity = isInstIdOf key v && result_is_list && n_args == arity
- good_id key arity = getUnique v == key && result_is_list && n_args == arity
-
- n_args :: Int
- n_args = length val_args
-
- result_is_list = resultTyIsList (idType v) ty_args val_args
-
-resultTyIsList ty ty_args val_args
- = go ty ty_args
- where
- go1 ty (_:tys) = case splitForAllTy_maybe ty of
- Just (_,ty) -> go1 ty tys
- Nothing -> False
- go1 ty [] = go2 ty val_args
-
- go2 ty (_:args) = case splitFunTy_maybe of
- Just (_,ty) -> go2 ty args
- Nothing -> False
-
- go2 ty [] = case splitTyConApp_maybe of
- Just (tycon, [_]) | tycon == listTyCon -> True
- other -> False
-
\begin{code}
deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr
deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above
= dsExpr expr `thenDs` \ core_expr ->
- returnDs (mkConApp consDataCon [Type (coreExprType core_expr), core_expr, list])
+ returnDs (mkConsExpr (coreExprType core_expr) core_expr list)
deListComp (GuardStmt guard locn : quals) list -- rule B above
= dsExpr guard `thenDs` \ core_guard ->
returnDs (Let (Rec [(h, rhs)]) letrec_body)
\end{code}
+
%************************************************************************
%* *
\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
%************************************************************************
@dfListComp@ are the rules used with foldr/build turned on:
+
\begin{verbatim}
-TE < [ e | ] >> c n = c e n
-TE << [ e | b , q ] >> c n = if b then TE << [ e | q ] >> c n else n
-TE << [ e | p <- l , q ] c n = foldr
- (\ TE << p >> b -> TE << [ e | q ] >> c b
- _ b -> b) n l
+TE[ e | ] c n = c e n
+TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n
+TE[ e | p <- l , q ] c n = let
+ f = \ x b -> case x of
+ p -> TE[ e | q ] c b
+ _ -> b
+ in
+ foldr f n l
\end{verbatim}
+
\begin{code}
-dfListComp :: Type -> Id -- 'c'; its type and id
- -> Type -> Id -- 'n'; its type and id
+dfListComp :: Id -> Id -- 'c' and 'n'
-> [TypecheckedStmt] -- the rest of the qual's
-> DsM CoreExpr
-dfListComp c_ty c_id n_ty n_id [ReturnStmt expr]
+dfListComp c_id n_id [ReturnStmt expr]
= dsExpr expr `thenDs` \ core_expr ->
returnDs (mkApps (Var c_id) [core_expr, Var n_id])
-dfListComp c_ty c_id n_ty n_id (GuardStmt guard locn : quals)
+dfListComp c_id n_id (GuardStmt guard locn : quals)
= dsExpr guard `thenDs` \ core_guard ->
- dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest ->
+ dfListComp c_id n_id quals `thenDs` \ core_rest ->
returnDs (mkIfThenElse core_guard core_rest (Var n_id))
-dfListComp c_ty c_id n_ty n_id (LetStmt binds : quals)
+dfListComp c_id n_id (LetStmt binds : quals)
-- new in 1.3, local bindings
- = dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest ->
+ = dfListComp c_id n_id quals `thenDs` \ core_rest ->
dsLet binds core_rest
-dfListComp c_ty c_id n_ty n_id (BindStmt pat list1 locn : quals)
+dfListComp c_id n_id (BindStmt pat list1 locn : quals)
-- evaluate the two lists
= dsExpr list1 `thenDs` \ core_list1 ->
-- find the required type
-
- let p_ty = outPatType pat
- b_ty = n_ty -- alias b_ty to n_ty
- fn_ty = mkFunTys [p_ty, b_ty] b_ty
- lst_ty = coreExprType core_list1
+ let x_ty = outPatType pat
+ b_ty = idType n_id
in
-- create some new local id's
-
- newSysLocalsDs [b_ty,p_ty,fn_ty,lst_ty] `thenDs` \ [b,p,fn,lst] ->
+ newSysLocalsDs [b_ty,x_ty] `thenDs` \ [b,x] ->
-- build rest of the comprehesion
+ dfListComp c_id b quals `thenDs` \ core_rest ->
- dfListComp c_ty c_id b_ty b quals `thenDs` \ core_rest ->
-- build the pattern match
-
- matchSimply (Var p) ListCompMatch pat core_rest (Var b) `thenDs` \ core_expr ->
+ matchSimply (Var x) ListCompMatch pat core_rest (Var b) `thenDs` \ core_expr ->
-- now build the outermost foldr, and return
-
returnDs (
- mkLets
- [NonRec fn (mkLams [p, b] core_expr),
- NonRec lst core_list1]
- (mkFoldr p_ty n_ty fn n_id lst)
+ Var foldrId `App` Type x_ty
+ `App` Type b_ty
+ `App` mkLams [x, b] core_expr
+ `App` Var n_id
+ `App` core_list1
)
\end{code}
-@mkBuild@ is sugar for building a build!
-
-@mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
-@ty@ is the type of the list.
-@tv@ is always a new type variable.
-@c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument.
- c :: a -> b -> b
- n :: b
- v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
--- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
-@e@ is the object right inside the @build@
-
-\begin{code}
-mkBuild :: Type
- -> TyVar
- -> Id
- -> Id
- -> Id
- -> CoreExpr -- template
- -> CoreExpr -- template
-
-mkBuild ty tv c n g expr
- = Let (NonRec g (mkLams [tv, c,n] expr))
- (mkApps (Var buildId) [Type ty, Var g])
-
-buildId = error "DsListComp: buildId"
-
-mkFoldr a b f z xs
- = mkApps (mkTyApps (Var foldrId) [a,b]) [Var f, Var z, Var xs]
-\end{code}
-
CanItFail(..), EquationInfo(..), MatchResult(..),
EqnNo, EqnSet,
+ mkDsLet, mkDsLets,
+
cantFailMatchResult, extractMatchResult,
combineMatchResults,
adjustMatchResult, adjustMatchResultDs,
mkCoLetsMatchResult, mkGuardedMatchResult,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
- mkErrorAppDs,
+ mkErrorAppDs, mkNilExpr, mkConsExpr,
mkSelectorBinds, mkTupleExpr, mkTupleSelector,
import DsMonad
import CoreUtils ( coreExprType )
-import PrelVals ( iRREFUT_PAT_ERROR_ID )
+import PrelInfo ( iRREFUT_PAT_ERROR_ID )
import Id ( idType, Id, mkWildId )
import Const ( Literal(..), Con(..) )
import TyCon ( isNewTyCon, tyConDataCons )
-import DataCon ( DataCon, dataConStrictMarks, dataConArgTys )
-import BasicTypes ( StrictnessMark(..) )
+import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed, dataConStrictMarks,
+ dataConArgTys, dataConId
+ )
import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy,
Type
)
-import TysWiredIn ( unitDataCon, tupleCon, stringTy, unitTy, unitDataCon )
+import TysWiredIn ( unitDataCon, tupleCon, stringTy, unitTy, unitDataCon,
+ nilDataCon, consDataCon
+ )
import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
import Outputable
\end{code}
%************************************************************************
%* *
+%* Building lets
+%* *
+%************************************************************************
+
+Use case, not let for unlifted types. The simplifier will turn some
+back again.
+
+\begin{code}
+mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
+mkDsLet (NonRec bndr rhs) body
+ | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
+mkDsLet bind body
+ = Let bind body
+
+mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
+mkDsLets binds body = foldr mkDsLet body binds
+\end{code}
+
+
+%************************************************************************
+%* *
%* Selecting match variables
%* *
%************************************************************************
extractMatchResult (MatchResult CanFail match_fn) fail_expr
= mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) ->
match_fn if_it_fails `thenDs` \ body ->
- returnDs (Let fail_bind body)
+ returnDs (mkDsLet fail_bind body)
combineMatchResults :: MatchResult -> MatchResult -> MatchResult
mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
mkCoLetsMatchResult binds match_result
- = adjustMatchResult (mkLets binds) match_result
+ = adjustMatchResult (mkDsLets binds) match_result
mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
returnDs (body',arg:args')
rebuildConArgs con (arg:args) (str:stricts) body
= rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
- case str of
- MarkedUnboxed pack_con tys ->
+ case maybeMarkedUnboxed str of
+ Just (pack_con, tys) ->
let id_tys = dataConArgTys pack_con ty_args in
newSysLocalsDs id_tys `thenDs` \ unpacked_args ->
returnDs (
- Let (NonRec arg (Con (DataCon pack_con)
- (map Type ty_args ++
- map Var unpacked_args))) body',
+ mkDsLet (NonRec arg (Con (DataCon pack_con)
+ (map Type ty_args ++
+ map Var unpacked_args))) body',
unpacked_args ++ real_args
)
_ -> returnDs (body', arg:real_args)
%* *
%************************************************************************
+Call the constructor Ids when building explicit lists, so that they
+interact well with rules.
+
+\begin{code}
+mkNilExpr :: Type -> CoreExpr
+mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty)
+
+mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
+mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[mkFailurePair]{Code for pattern-matching and other failures}
+%* *
+%************************************************************************
+
Generally, we handle pattern matching failure like this: let-bind a
fail-variable, and use that variable if the thing fails:
\begin{verbatim}
import DataCon ( dataConFieldLabels, dataConArgTys )
import MatchCon ( matchConFamily )
import MatchLit ( matchLiterals )
-import PrelVals ( pAT_ERROR_ID )
+import PrelInfo ( pAT_ERROR_ID )
import Type ( isUnLiftedType, splitAlgTyConApp,
Type
)
tidy1 v (RecPat data_con pat_ty tvs dicts rpats) match_result
= returnDs (ConPat data_con pat_ty tvs dicts pats, match_result)
where
- {-
- Special case to handle C{}, where C is a constructor
- that hasn't got any labelled fields - the Haskell98 report
- doesn't seem to make that constraint (not that I think it
- should).
- -- sof 5/99
- -}
- pats
- | null con_flabels = map (WildPat) con_arg_tys'
- | otherwise = map mk_pat tagged_arg_tys
+ pats = map mk_pat tagged_arg_tys
-- Boring stuff to find the arg-tys of the constructor
(_, inst_tys, _) = splitAlgTyConApp pat_ty
con_arg_tys' = dataConArgTys data_con inst_tys
- con_flabels = dataConFieldLabels data_con
- tagged_arg_tys = con_arg_tys' `zip` con_flabels
+ tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con)
-- mk_pat picks a WildPat of the appropriate type for absent fields,
-- and the specified pattern for present fields
--others:
import Id ( Id )
+import NameSet ( NameSet, nameSetToList )
import BasicTypes ( RecFlag(..), Fixity )
import Outputable
import Bag
SrcLoc
| FunMonoBind id
- Bool -- True => infix declaration
+ Bool -- True => infix declaration
[Match id pat]
SrcLoc
| CoreMonoBind id -- TRANSLATION
CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
- | AbsBinds -- Binds abstraction; TRANSLATION
- [TyVar] -- Type variables
- [id] -- Dicts
- [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
+ | AbsBinds -- Binds abstraction; TRANSLATION
+ [TyVar] -- Type variables
+ [id] -- Dicts
+ [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
+ NameSet -- Set of *polymorphic* variables that have an INLINE pragma
(MonoBinds id pat) -- The "business end"
-- Creates bindings for *new* (polymorphic, overloaded) locals
ppr_monobind (CoreMonoBind name expr)
= sep [ppr name <+> equals, nest 4 (ppr expr)]
-ppr_monobind (AbsBinds tyvars dictvars exports val_binds)
+ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
= sep [ptext SLIT("AbsBinds"),
brackets (interpp'SP tyvars),
brackets (interpp'SP dictvars),
- brackets (interpp'SP exports)]
+ brackets (interpp'SP exports),
+ brackets (interpp'SP (nameSetToList inlines))]
$$
nest 4 (ppr val_binds)
\end{code}
| SpecSig name -- specialise a function or datatype ...
(HsType name) -- ... to these types
- (Maybe name) -- ... maybe using this as the code for it
SrcLoc
| InlineSig name -- INLINE f
where
sig_for_me (Sig n _ _) = f n
sig_for_me (ClassOpSig n _ _ _) = f n
- sig_for_me (SpecSig n _ _ _) = f n
+ sig_for_me (SpecSig n _ _) = f n
sig_for_me (InlineSig n _) = f n
sig_for_me (NoInlineSig n _) = f n
sig_for_me (SpecInstSig _ _) = False
ppr_sig (ClassOpSig var _ ty _)
= sep [ppr var <+> dcolon, nest 4 (ppr ty)]
-ppr_sig (SpecSig var ty using _)
+ppr_sig (SpecSig var ty _)
= sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
- nest 4 (hsep [ppr ty, pp_using using, text "#-}"])
+ nest 4 (ppr ty <+> text "#-}")
]
- where
- pp_using Nothing = empty
- pp_using (Just me) = hsep [char '=', ppr me]
ppr_sig (InlineSig var _)
= hsep [text "{-# INLINE", ppr var, text "#-}"]
\begin{code}
module HsCore (
UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
- UfBinding(..), UfCon(..)
+ UfBinding(..), UfCon(..),
+ HsIdInfo(..), HsStrictnessInfo(..),
+ IfaceSig(..), UfRuleBody(..)
) where
#include "HsVersions.h"
import HsTypes ( HsType, pprParendHsType )
-- others:
+import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo, CprInfo )
+import CoreSyn ( CoreBndr, CoreExpr )
+import Demand ( Demand )
import Const ( Literal )
import Type ( Kind )
import CostCentre
+import SrcLoc ( SrcLoc )
import Outputable
\end{code}
data UfNote name = UfSCC CostCentre
| UfCoerce (HsType name)
| UfInlineCall
+ | UfInlineMe
type UfAlt name = (UfCon name, [name], UfExpr name)
ppr (UfTyBinder name kind) = hsep [ppr name, dcolon, ppr kind]
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Signatures in interface files}
+%* *
+%************************************************************************
+
+\begin{code}
+data IfaceSig name
+ = IfaceSig name
+ (HsType name)
+ [HsIdInfo name]
+ SrcLoc
+
+instance (Outputable name) => Outputable (IfaceSig name) where
+ ppr (IfaceSig var ty _ _)
+ = hang (hsep [ppr var, dcolon])
+ 4 (ppr ty)
+
+data HsIdInfo name
+ = HsArity ArityInfo
+ | HsStrictness HsStrictnessInfo
+ | HsUnfold InlinePragInfo (Maybe (UfExpr name))
+ | HsUpdate UpdateInfo
+ | HsSpecialise (UfRuleBody name)
+ | HsNoCafRefs
+ | HsCprInfo CprInfo
+ | HsWorker name -- Worker, if any
+
+data HsStrictnessInfo
+ = HsStrictnessInfo ([Demand], Bool)
+ | HsBottom
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Rules in interface files}
+%* *
+%************************************************************************
+
+\begin{code}
+data UfRuleBody name = UfRuleBody FAST_STRING [UfBinder name] [UfExpr name] (UfExpr name) -- Pre typecheck
+ | CoreRuleBody FAST_STRING [CoreBndr] [CoreExpr] CoreExpr -- Post typecheck
+\end{code}
\begin{code}
module HsDecls (
- HsDecl(..), TyClDecl(..), InstDecl(..),
+ HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
DefaultDecl(..), ForeignDecl(..), ForKind(..),
ExtName(..), isDynamic,
ConDecl(..), ConDetails(..), BangType(..),
- IfaceSig(..), SpecDataSig(..), HsIdInfo(..), HsStrictnessInfo(..),
+ IfaceSig(..), SpecDataSig(..),
hsDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls
) where
-- friends:
import HsBinds ( HsBinds, MonoBinds, Sig, FixitySig(..), nullMonoBinds )
+import HsExpr ( HsExpr )
import HsPragmas ( DataPragmas, ClassPragmas )
import HsTypes
-import HsCore ( UfExpr )
+import HsCore ( UfExpr, UfBinder, IfaceSig(..), UfRuleBody )
import BasicTypes ( Fixity, NewOrData(..) )
-import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo, CprInfo )
-import Demand ( Demand )
import CallConv ( CallConv, pprCallConv )
+import Var ( TyVar )
-- others:
+import PprType
import Outputable
import SrcLoc ( SrcLoc )
import Util
| ForD (ForeignDecl name)
| SigD (IfaceSig name)
| FixD (FixitySig name)
+ | RuleD (RuleDecl name pat)
-- NB: all top-level fixity decls are contained EITHER
-- EITHER FixDs
-- d) top level decls
--
-- The latter is for class methods only
-
--- It's a bit wierd that the fixity decls in the ValD
--- cover all the classops and imported decls too, but it's convenient
--- For a start, it means we don't need a FixD
\end{code}
\begin{code}
hsDeclName :: (Outputable name, Outputable pat)
=> HsDecl name pat -> name
#endif
-hsDeclName (TyClD decl) = tyClDeclName decl
-hsDeclName (SigD (IfaceSig name _ _ _)) = name
-hsDeclName (InstD (InstDecl _ _ _ (Just name) _)) = name
-hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name
-hsDeclName (FixD (FixitySig name _ _)) = name
+hsDeclName (TyClD decl) = tyClDeclName decl
+hsDeclName (SigD (IfaceSig name _ _ _)) = name
+hsDeclName (InstD (InstDecl _ _ _ name _)) = name
+hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name
+hsDeclName (FixD (FixitySig name _ _)) = name
-- Others don't make sense
#ifdef DEBUG
hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x)
#endif
tyClDeclName :: TyClDecl name pat -> name
-tyClDeclName (TyData _ _ name _ _ _ _ _) = name
-tyClDeclName (TySynonym name _ _ _) = name
-tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _) = name
+tyClDeclName (TyData _ _ name _ _ _ _ _) = name
+tyClDeclName (TySynonym name _ _ _) = name
+tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ _) = name
\end{code}
\begin{code}
ppr (InstD inst) = ppr inst
ppr (ForD fd) = ppr fd
ppr (FixD fd) = ppr fd
-
-{- Why do we need ordering on decls?
-
-#ifdef DEBUG
--- hsDeclName needs more context when DEBUG is on
-instance (Outputable name, Outputable pat, Eq name)
- => Eq (HsDecl name pat) where
- d1 == d2 = hsDeclName d1 == hsDeclName d2
-
-instance (Outputable name, Outputable pat, Ord name)
- => Ord (HsDecl name pat) where
- d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
-#else
-instance (Eq name) => Eq (HsDecl name pat) where
- d1 == d2 = hsDeclName d1 == hsDeclName d2
-
-instance (Ord name) => Ord (HsDecl name pat) where
- d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
-#endif
--}
+ ppr (RuleD rd) = ppr rd
\end{code}
(HsType name) -- synonym expansion
SrcLoc
- | ClassDecl (Context name) -- context...
- name -- name of the class
- [HsTyVar name] -- the class type variables
- [Sig name] -- methods' signatures
+ | ClassDecl (Context name) -- context...
+ name -- name of the class
+ [HsTyVar name] -- the class type variables
+ [Sig name] -- methods' signatures
(MonoBinds name pat) -- default methods
(ClassPragmas name)
- name name -- The names of the tycon and datacon for this class
- -- These are filled in by the renamer
+ name name [name] -- The names of the tycon, datacon, and superclass selectors
+ -- for this class. These are filled in as the ClassDecl is made.
SrcLoc
\end{code}
countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int)
-- class, data, newtype, synonym decls
countTyClDecls decls
- = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ <- decls],
+ = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ _ <- decls],
length [() | TyData DataType _ _ _ _ _ _ _ <- decls],
length [() | TyData NewType _ _ _ _ _ _ _ <- decls],
length [() | TySynonym _ _ _ _ <- decls])
isDataDecl (TyData _ _ _ _ _ _ _ _) = True
isDataDecl other = False
-isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _) = True
-isClassDecl other = False
+isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ _) = True
+isClassDecl other = False
\end{code}
\begin{code}
NewType -> SLIT("newtype")
DataType -> SLIT("data")
- ppr (ClassDecl context clas tyvars sigs methods pragmas _ _ src_loc)
+ ppr (ClassDecl context clas tyvars sigs methods pragmas _ _ _ src_loc)
| null sigs -- No "where" part
= top_matter
[Sig name] -- User-supplied pragmatic info
- (Maybe name) -- Name for the dictionary function
+ name -- Name for the dictionary function
SrcLoc
\end{code}
%************************************************************************
%* *
-\subsection{Signatures in interface files}
+\subsection{Transformation rules}
%* *
%************************************************************************
\begin{code}
-data IfaceSig name
- = IfaceSig name
- (HsType name)
- [HsIdInfo name]
- SrcLoc
+data RuleDecl name pat
+ = RuleDecl
+ FAST_STRING -- Rule name
+ [name] -- Forall'd tyvars, filled in by the renamer with
+ -- tyvars mentioned in sigs; then filled out by typechecker
+ [RuleBndr name] -- Forall'd term vars
+ (HsExpr name pat) -- LHS
+ (HsExpr name pat) -- RHS
+ SrcLoc
+
+ | IfaceRuleDecl -- One that's come in from an interface file
+ name
+ (UfRuleBody name)
+ SrcLoc
+
+data RuleBndr name
+ = RuleBndr name
+ | RuleBndrSig name (HsType name)
-instance (Outputable name) => Outputable (IfaceSig name) where
- ppr (IfaceSig var ty _ _)
- = hang (hsep [ppr var, dcolon])
- 4 (ppr ty)
-
-data HsIdInfo name
- = HsArity ArityInfo
- | HsStrictness HsStrictnessInfo
- | HsUnfold InlinePragInfo (Maybe (UfExpr name))
- | HsUpdate UpdateInfo
- | HsSpecialise [HsTyVar name] [HsType name] (UfExpr name)
- | HsNoCafRefs
- | HsCprInfo CprInfo
- | HsWorker name [name] -- Worker, if any
- -- and needed constructors
-
-data HsStrictnessInfo
- = HsStrictnessInfo ([Demand], Bool)
- | HsBottom
+instance (Outputable name, Outputable pat)
+ => Outputable (RuleDecl name pat) where
+ ppr (RuleDecl name tvs ns lhs rhs loc)
+ = text "RULE" <+> doubleQuotes (ptext name) <> colon <+>
+ sep [pp_forall, ppr lhs, equals <+> ppr rhs]
+ where
+ pp_forall | null tvs && null ns = empty
+ | otherwise = text "forall" <+>
+ fsep (map ppr tvs ++ map ppr ns)
+ <> dot
+ ppr (IfaceRuleDecl var body loc) = text "An imported rule..."
+
+instance Outputable name => Outputable (RuleBndr name) where
+ ppr (RuleBndr name) = ppr name
+ ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
\end{code}
-- friends:
import {-# SOURCE #-} HsMatches ( pprMatches, pprMatch, Match )
-import HsBinds ( HsBinds )
+import HsBinds ( HsBinds(..) )
import HsBasic ( HsLit )
import BasicTypes ( Fixity(..), FixityDirection(..) )
import HsTypes ( HsType )
#include "HsVersions.h"
-import Module ( Module, pprModule, moduleIfaceFlavour, bootFlavour )
+import Module ( ModuleName, WhereFrom, pprModuleName )
import Outputable
import SrcLoc ( SrcLoc )
\end{code}
One per \tr{import} declaration in a module.
\begin{code}
data ImportDecl name
- = ImportDecl Module -- module name
+ = ImportDecl ModuleName -- module name
+ WhereFrom
Bool -- True => qualified
- (Maybe Module) -- as Module
+ (Maybe ModuleName) -- as Module
(Maybe (Bool, [IE name])) -- (True => hiding, names)
SrcLoc
\end{code}
\begin{code}
instance (Outputable name) => Outputable (ImportDecl name) where
- ppr (ImportDecl mod qual as spec _)
- = hang (hsep [ptext SLIT("import"), pp_src,
- pp_qual qual, pprModule mod, pp_as as])
+ ppr (ImportDecl mod from qual as spec _)
+ = hang (hsep [ptext SLIT("import"), ppr from,
+ pp_qual qual, pprModuleName mod, pp_as as])
4 (pp_spec spec)
where
- pp_src | bootFlavour (moduleIfaceFlavour mod) = ptext SLIT("{-# SOURCE #-}")
- | otherwise = empty
-
pp_qual False = empty
pp_qual True = ptext SLIT("qualified")
pp_as Nothing = empty
- pp_as (Just a) = ptext SLIT("as ") <+> pprModule a
+ pp_as (Just a) = ptext SLIT("as ") <+> pprModuleName a
pp_spec Nothing = empty
pp_spec (Just (False, spec))
| IEThingAbs name -- Class/Type (can't tell)
| IEThingAll name -- Class/Type plus all methods/constructors
| IEThingWith name [name] -- Class/Type plus some methods/constructors
- | IEModuleContents Module -- (Export Only)
+ | IEModuleContents ModuleName -- (Export Only)
\end{code}
\begin{code}
ppr (IEThingWith thing withs)
= ppr thing <> parens (fsep (punctuate comma (map ppr withs)))
ppr (IEModuleContents mod)
- = ptext SLIT("module") <+> pprModule mod
+ = ptext SLIT("module") <+> pprModuleName mod
\end{code}
import Outputable
import SrcLoc ( SrcLoc )
import Bag
-import Module ( Module, pprModule )
+import Module ( ModuleName, pprModuleName )
\end{code}
All we actually declare here is the top-level structure for a module.
\begin{code}
data HsModule name pat
= HsModule
- Module -- module name
+ ModuleName -- module name
(Maybe Version) -- source interface version number
(Maybe [IE name]) -- export list; Nothing => export everything
-- Just [] => export *nothing* (???)
decls src_loc)
= vcat [
case exports of
- Nothing -> hsep [ptext SLIT("module"), pprModule name, ptext SLIT("where")]
+ Nothing -> hsep [ptext SLIT("module"), pprModuleName name, ptext SLIT("where")]
Just es -> vcat [
- hsep [ptext SLIT("module"), pprModule name, lparen],
+ hsep [ptext SLIT("module"), pprModuleName name, lparen],
nest 8 (fsep (punctuate comma (map ppr es))),
nest 4 (ptext SLIT(") where"))
],
opt_D_dump_rdr,
opt_D_dump_realC,
opt_D_dump_rn,
+ opt_D_dump_rules,
opt_D_dump_simpl,
opt_D_dump_simpl_iterations,
+ opt_D_dump_simpl_stats,
opt_D_dump_spec,
opt_D_dump_stg,
opt_D_dump_stranal,
opt_D_dump_usagesp,
opt_D_dump_worker_wrapper,
opt_D_show_passes,
- opt_D_show_rn_imports,
- opt_D_show_rn_stats,
- opt_D_show_rn_trace,
- opt_D_simplifier_stats,
+ opt_D_dump_rn_trace,
+ opt_D_dump_rn_stats,
opt_D_source_stats,
opt_D_verbose_core2core,
opt_D_verbose_stg2stg,
opt_DoEtaReduction,
opt_DoSemiTagging,
opt_FoldrBuildOn,
- opt_InterfaceUnfoldThreshold,
opt_LiberateCaseThreshold,
opt_NoPreInlining,
opt_StgDoLetNoEscapes,
opt_UnfoldCasms,
- opt_UnfoldingConDiscount,
- opt_UnfoldingCreationThreshold,
- opt_UnfoldingKeenessFactor,
- opt_UnfoldingUseThreshold,
opt_UsageSPOn,
opt_UnboxStrictFields,
+ opt_SimplNoPreInlining,
+ opt_SimplDoEtaReduction,
+ opt_SimplDoCaseElim,
+ opt_SimplDoLambdaEtaExpansion,
+ opt_SimplCaseOfCase,
+ opt_SimplCaseMerge,
+ opt_SimplLetToCase,
+ opt_SimplPedanticBottoms,
+
+ -- Unfolding control
+ opt_UF_HiFileThreshold,
+ opt_UF_CreationThreshold,
+ opt_UF_UseThreshold,
+ opt_UF_ScrutConDiscount,
+ opt_UF_FunAppDiscount,
+ opt_UF_PrimArgDiscount,
+ opt_UF_KeenessFactor,
+ opt_UF_CheapOp,
+ opt_UF_DearOp,
+ opt_UF_NoRepLit,
-- misc opts
opt_CompilingPrelude,
opt_GranMacros,
opt_HiMap,
opt_HiVersion,
+ opt_HistorySize,
opt_IgnoreAsserts,
opt_IgnoreIfacePragmas,
opt_NoHiCheck,
opt_ProduceExportHStubs,
opt_ProduceHi,
opt_ProduceS,
- opt_PruneInstDecls,
- opt_PruneTyDecls,
+ opt_NoPruneDecls,
opt_ReportCompile,
opt_SourceUnchanged,
opt_Static,
opt_Unregisterised,
opt_Verbose,
+ -- Code generation
opt_UseVanillaRegs,
opt_UseFloatRegs,
opt_UseDoubleRegs,
(\tr{simplCore/SimplCore.lhs), and in the STG-to-STG processing loop
(\tr{simplStg/SimplStg.lhs}).
+
%************************************************************************
%* *
\subsection{Datatypes associated with command-line options}
(SimplifierSwitch -> SwitchResult)
-- Each run of the simplifier can take a different
-- set of simplifier-specific flags.
- | CoreDoCalcInlinings1
- | CoreDoCalcInlinings2
| CoreDoFloatInwards
| CoreDoFullLaziness
| CoreLiberateCase
| CoreDoStrictness
| CoreDoWorkerWrapper
| CoreDoSpecialising
- | CoreDoFoldrBuildWorkerWrapper
- | CoreDoFoldrBuildWWAnal
| CoreDoUSPInf
| CoreDoCPResult
\end{code}
\begin{code}
data SimplifierSwitch
- = SimplOkToDupCode
- | SimplFloatLetsExposingWHNF
- | SimplOkToFloatPrimOps
- | SimplAlwaysFloatLetsFromLets
- | SimplDoCaseElim
- | SimplCaseOfCase
- | SimplLetToCase
- | SimplMayDeleteConjurableIds
- | SimplPedanticBottoms -- see Simplifier for an explanation
- | SimplDoArityExpand -- expand arity of bindings
- | SimplDoFoldrBuild -- This is the per-simplification flag;
- -- see also FoldrBuildOn, used elsewhere
- -- in the compiler.
- | SimplDoInlineFoldrBuild
- -- inline foldr/build (*after* f/b rule is used)
-
- | IgnoreINLINEPragma
- | SimplDoLambdaEtaExpansion
-
- | EssentialUnfoldingsOnly -- never mind the thresholds, only
- -- do unfoldings that *must* be done
- -- (to saturate constructors and primitives)
-
- | MaxSimplifierIterations Int
-
- | SimplNoLetFromCase -- used when turning off floating entirely
- | SimplNoLetFromApp -- (for experimentation only) WDP 95/10
- | SimplNoLetFromStrictLet
-
- | SimplCaseMerge
- | SimplPleaseClone
+ = MaxSimplifierIterations Int
+ | SimplInlinePhase Int
\end{code}
%************************************************************************
opt_D_dump_stg = lookUp SLIT("-ddump-stg")
opt_D_dump_stranal = lookUp SLIT("-ddump-stranal")
opt_D_dump_tc = lookUp SLIT("-ddump-tc")
+opt_D_dump_rules = lookUp SLIT("-ddump-rules")
opt_D_dump_usagesp = lookUp SLIT("-ddump-usagesp")
opt_D_dump_worker_wrapper = lookUp SLIT("-ddump-workwrap")
opt_D_show_passes = lookUp SLIT("-dshow-passes")
-opt_D_show_rn_imports = lookUp SLIT("-dshow-rn-imports")
-opt_D_show_rn_trace = lookUp SLIT("-dshow-rn-trace")
-opt_D_show_rn_stats = lookUp SLIT("-dshow-rn-stats")
-opt_D_simplifier_stats = lookUp SLIT("-dsimplifier-stats")
+opt_D_dump_rn_trace = lookUp SLIT("-ddump-rn-trace")
+opt_D_dump_rn_stats = lookUp SLIT("-ddump-rn-stats")
+opt_D_dump_simpl_stats = lookUp SLIT("-ddump-simpl-stats")
opt_D_source_stats = lookUp SLIT("-dsource-stats")
opt_D_verbose_core2core = lookUp SLIT("-dverbose-simpl")
opt_D_verbose_stg2stg = lookUp SLIT("-dverbose-stg")
opt_DoEtaReduction = lookUp SLIT("-fdo-eta-reduction")
opt_DoSemiTagging = lookUp SLIT("-fsemi-tagging")
opt_FoldrBuildOn = lookUp SLIT("-ffoldr-build-on")
-opt_InterfaceUnfoldThreshold = lookup_def_int "-funfolding-interface-threshold" iNTERFACE_UNFOLD_THRESHOLD
-opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" lIBERATE_CASE_THRESHOLD
+opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" (10::Int)
opt_NoPreInlining = lookUp SLIT("-fno-pre-inlining")
opt_StgDoLetNoEscapes = lookUp SLIT("-flet-no-escape")
opt_UnfoldCasms = lookUp SLIT("-funfold-casms-in-hi-file")
-opt_UnfoldingConDiscount = lookup_def_int "-funfolding-con-discount" uNFOLDING_CON_DISCOUNT_WEIGHT
-opt_UnfoldingCreationThreshold = lookup_def_int "-funfolding-creation-threshold" uNFOLDING_CREATION_THRESHOLD
-opt_UnfoldingKeenessFactor = lookup_def_float "-funfolding-keeness-factor" uNFOLDING_KEENESS_FACTOR
-opt_UnfoldingUseThreshold = lookup_def_int "-funfolding-use-threshold" uNFOLDING_USE_THRESHOLD
opt_UsageSPOn = lookUp SLIT("-fusagesp-on")
opt_UnboxStrictFields = lookUp SLIT("-funbox-strict-fields")
opt_GranMacros = lookUp SLIT("-fgransim")
opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files
opt_HiVersion = lookup_def_int "-fhi-version=" 0 -- what version we're compiling.
+opt_HistorySize = lookup_def_int "-fhistory-size" 20
opt_IgnoreAsserts = lookUp SLIT("-fignore-asserts")
opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas")
opt_NoHiCheck = lookUp SLIT("-fno-hi-version-check")
opt_ProduceExportCStubs = lookup_str "-F="
opt_ProduceExportHStubs = lookup_str "-FH="
opt_ProduceHi = lookup_str "-hifile=" -- the one to produce this time
+
+-- Simplifier switches
+opt_SimplNoPreInlining = lookUp SLIT("-fno-pre-inlining")
+ -- NoPreInlining is there just to see how bad things
+ -- get if you don't do it!
+opt_SimplDoEtaReduction = lookUp SLIT("-fdo-eta-reduction")
+opt_SimplDoCaseElim = lookUp SLIT("-fdo-case-elim")
+opt_SimplDoLambdaEtaExpansion = lookUp SLIT("-fdo-lambda-eta-expansion")
+opt_SimplCaseOfCase = lookUp SLIT("-fcase-of-case")
+opt_SimplCaseMerge = lookUp SLIT("-fcase-merge")
+opt_SimplLetToCase = lookUp SLIT("-flet-to-case")
+opt_SimplPedanticBottoms = lookUp SLIT("-fpedantic-bottoms")
+
+-- Unfolding control
+opt_UF_HiFileThreshold = lookup_def_int "-funfolding-interface-threshold" (30::Int)
+opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (30::Int)
+opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (8::Int) -- Discounts can be big
+opt_UF_ScrutConDiscount = lookup_def_int "-funfolding-con-discount" (3::Int)
+opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) -- It's great to inline a fn
+opt_UF_PrimArgDiscount = lookup_def_int "-funfolding-prim-discount" (1::Int)
+opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (2.0::Float)
+
+opt_UF_CheapOp = ( 1 :: Int)
+opt_UF_DearOp = ( 8 :: Int)
+opt_UF_NoRepLit = ( 20 :: Int) -- Strings can be pretty big
+
opt_ProduceS = lookup_str "-S="
-opt_ReportCompile = lookUp SLIT("-freport-compile")
-opt_PruneTyDecls = not (lookUp SLIT("-fno-prune-tydecls"))
-opt_PruneInstDecls = not (lookUp SLIT("-fno-prune-instdecls"))
-opt_SourceUnchanged = lookUp SLIT("-fsource-unchanged")
-opt_Static = lookUp SLIT("-static")
-opt_Unregisterised = lookUp SLIT("-funregisterised")
-opt_Verbose = lookUp SLIT("-v")
+opt_ReportCompile = lookUp SLIT("-freport-compile")
+opt_NoPruneDecls = lookUp SLIT("-fno-prune-decls")
+opt_SourceUnchanged = lookUp SLIT("-fsource-unchanged")
+opt_Static = lookUp SLIT("-static")
+opt_Unregisterised = lookUp SLIT("-funregisterised")
+opt_Verbose = lookUp SLIT("-v")
opt_UseVanillaRegs | opt_Unregisterised = 0
| otherwise = mAX_Real_Vanilla_REG
| otherwise = mAX_Real_Double_REG
opt_UseLongRegs | opt_Unregisterised = 0
| otherwise = mAX_Real_Long_REG
-
--- opt_UnfoldingOverrideThreshold = lookup_int "-funfolding-override-threshold"
\end{code}
\begin{code}
"-fsimplify" -> -- gather up SimplifierSwitches specially...
simpl_sep opts defaultSimplSwitches core_td stg_td
- "-fcalc-inlinings1"-> CORE_TD(CoreDoCalcInlinings1)
- "-fcalc-inlinings2"-> CORE_TD(CoreDoCalcInlinings2)
"-ffloat-inwards" -> CORE_TD(CoreDoFloatInwards)
"-ffull-laziness" -> CORE_TD(CoreDoFullLaziness)
"-fliberate-case" -> CORE_TD(CoreLiberateCase)
"-fstrictness" -> CORE_TD(CoreDoStrictness)
"-fworker-wrapper" -> CORE_TD(CoreDoWorkerWrapper)
"-fspecialise" -> CORE_TD(CoreDoSpecialising)
- "-ffoldr-build-worker-wrapper" -> CORE_TD(CoreDoFoldrBuildWorkerWrapper)
- "-ffoldr-build-ww-anal" -> CORE_TD(CoreDoFoldrBuildWWAnal)
"-fusagesp" -> CORE_TD(CoreDoUSPInf)
"-fcpr-analyse" -> CORE_TD(CoreDoCPResult)
in
sep opts (this_simpl : core_td) stg_td
-# define SIMPL_SW(sw) simpl_sep opts (sw:simpl_sw) core_td stg_td
-
- -- the non-"just match a string" options are at the end...
- "-fcode-duplication-ok" -> SIMPL_SW(SimplOkToDupCode)
- "-ffloat-lets-exposing-whnf" -> SIMPL_SW(SimplFloatLetsExposingWHNF)
- "-ffloat-primops-ok" -> SIMPL_SW(SimplOkToFloatPrimOps)
- "-falways-float-lets-from-lets" -> SIMPL_SW(SimplAlwaysFloatLetsFromLets)
- "-fdo-case-elim" -> SIMPL_SW(SimplDoCaseElim)
- "-fdo-lambda-eta-expansion" -> SIMPL_SW(SimplDoLambdaEtaExpansion)
- "-fdo-foldr-build" -> SIMPL_SW(SimplDoFoldrBuild)
- "-fdo-arity-expand" -> SIMPL_SW(SimplDoArityExpand)
- "-fdo-inline-foldr-build" -> SIMPL_SW(SimplDoInlineFoldrBuild)
- "-fcase-of-case" -> SIMPL_SW(SimplCaseOfCase)
- "-fcase-merge" -> SIMPL_SW(SimplCaseMerge)
- "-flet-to-case" -> SIMPL_SW(SimplLetToCase)
- "-fpedantic-bottoms" -> SIMPL_SW(SimplPedanticBottoms)
- "-fmay-delete-conjurable-ids" -> SIMPL_SW(SimplMayDeleteConjurableIds)
- "-fessential-unfoldings-only" -> SIMPL_SW(EssentialUnfoldingsOnly)
- "-fignore-inline-pragma" -> SIMPL_SW(IgnoreINLINEPragma)
- "-fno-let-from-case" -> SIMPL_SW(SimplNoLetFromCase)
- "-fno-let-from-app" -> SIMPL_SW(SimplNoLetFromApp)
- "-fno-let-from-strict-let" -> SIMPL_SW(SimplNoLetFromStrictLet)
- "-fclone-binds" -> SIMPL_SW(SimplPleaseClone)
-
- o | starts_with_msi -> SIMPL_SW(MaxSimplifierIterations (read after_msi))
- where
- maybe_msi = startsWith "-fmax-simplifier-iterations" o
- starts_with_msi = maybeToBool maybe_msi
- (Just after_msi) = maybe_msi
+ opt -> case matchSimplSw opt of
+ Just sw -> simpl_sep opts (sw:simpl_sw) core_td stg_td
+ Nothing -> simpl_sep opts simpl_sw core_td stg_td
- _ -> -- NB: the driver is really supposed to handle bad options
- simpl_sep opts simpl_sw core_td stg_td
+matchSimplSw opt
+ = firstJust [ matchSwInt opt "-fmax-simplifier-iterations" MaxSimplifierIterations
+ , matchSwInt opt "-finline-phase" SimplInlinePhase
+ ]
+
+matchSwBool :: String -> String -> a -> Maybe a
+matchSwBool opt str sw | opt == str = Just sw
+ | otherwise = Nothing
+
+matchSwInt :: String -> String -> (Int -> a) -> Maybe a
+matchSwInt opt str sw = case startsWith str opt of
+ Just opt_left -> Just (sw (read opt_left))
+ Nothing -> Nothing
\end{code}
%************************************************************************
a < b = tagOf_SimplSwitch a _LT_ tagOf_SimplSwitch b
a <= b = tagOf_SimplSwitch a _LE_ tagOf_SimplSwitch b
-tagOf_SimplSwitch SimplOkToDupCode =(ILIT(0) :: FAST_INT)
-tagOf_SimplSwitch SimplFloatLetsExposingWHNF = ILIT(1)
-tagOf_SimplSwitch SimplOkToFloatPrimOps = ILIT(2)
-tagOf_SimplSwitch SimplAlwaysFloatLetsFromLets = ILIT(3)
-tagOf_SimplSwitch SimplDoCaseElim = ILIT(4)
-tagOf_SimplSwitch SimplCaseOfCase = ILIT(6)
-tagOf_SimplSwitch SimplLetToCase = ILIT(7)
-tagOf_SimplSwitch SimplMayDeleteConjurableIds = ILIT(9)
-tagOf_SimplSwitch SimplPedanticBottoms = ILIT(10)
-tagOf_SimplSwitch SimplDoArityExpand = ILIT(11)
-tagOf_SimplSwitch SimplDoFoldrBuild = ILIT(12)
-tagOf_SimplSwitch SimplDoInlineFoldrBuild = ILIT(14)
-tagOf_SimplSwitch IgnoreINLINEPragma = ILIT(15)
-tagOf_SimplSwitch SimplDoLambdaEtaExpansion = ILIT(16)
-tagOf_SimplSwitch EssentialUnfoldingsOnly = ILIT(19)
-tagOf_SimplSwitch (MaxSimplifierIterations _) = ILIT(21)
-tagOf_SimplSwitch SimplNoLetFromCase = ILIT(27)
-tagOf_SimplSwitch SimplNoLetFromApp = ILIT(28)
-tagOf_SimplSwitch SimplNoLetFromStrictLet = ILIT(29)
-tagOf_SimplSwitch SimplCaseMerge = ILIT(31)
-tagOf_SimplSwitch SimplPleaseClone = ILIT(32)
--- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
+tagOf_SimplSwitch (SimplInlinePhase _) = ILIT(1)
+tagOf_SimplSwitch (MaxSimplifierIterations _) = ILIT(2)
-tagOf_SimplSwitch _ = panic# "tagOf_SimplSwitch"
+-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
-lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplPleaseClone)
+lAST_SIMPL_SWITCH_TAG = 2
\end{code}
%************************************************************************
-- ie the ones that occur earliest in the list.
sw_tbl :: Array Int SwitchResult
-
sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
all_undefined)
// defined_elems
case (indexArray# stuff (tagOf_SimplSwitch switch)) of
#if __GLASGOW_HASKELL__ < 400
Lift v -> v
-#elif __GLASGOW_HASKELL__ < 403
- (# _, v #) -> v
#else
- (# v #) -> v
+ (# _, v #) -> v
#endif
}
where
- mk_assoc_elem k@(MaxSimplifierIterations lvl) = (IBOX(tagOf_SimplSwitch k), SwInt lvl)
-
- mk_assoc_elem k = (IBOX(tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
+ mk_assoc_elem k@(MaxSimplifierIterations lvl) = (IBOX(tagOf_SimplSwitch k), SwInt lvl)
+ mk_assoc_elem k@(SimplInlinePhase n) = (IBOX(tagOf_SimplSwitch k), SwInt n)
+ mk_assoc_elem k = (IBOX(tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
-- cannot have duplicates if we are going to use the array thing
rm_dups switches_so_far switch
Default settings for simplifier switches
\begin{code}
-defaultSimplSwitches = [MaxSimplifierIterations 1
- ]
+defaultSimplSwitches = [MaxSimplifierIterations 1]
\end{code}
%************************************************************************
\end{code}
\begin{code}
-startsWith, endsWith :: String -> String -> Maybe String
+startsWith :: String -> String -> Maybe String
+-- startsWith pfx (pfx++rest) = Just rest
startsWith [] str = Just str
startsWith (c:cs) (s:ss)
= if c /= s then Nothing else startsWith cs ss
startsWith _ [] = Nothing
+endsWith :: String -> String -> Maybe String
endsWith cs ss
= case (startsWith (reverse cs) (reverse ss)) of
Nothing -> Nothing
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+\section{Code output phase}
+
+\begin{code}
+module CodeOutput( codeOutput ) where
+
+#include "HsVersions.h"
+
+#if ! OMIT_NATIVE_CODEGEN
+import AsmCodeGen ( nativeCodeGen )
+#endif
+
+import AbsCSyn ( AbstractC, absCNop )
+import PprAbsC ( dumpRealC, writeRealC )
+import UniqSupply ( UniqSupply )
+import Module ( Module, moduleString )
+import CmdLineOpts
+import Maybes ( maybeToBool )
+import ErrUtils ( doIfSet, dumpIfSet )
+import Outputable
+import IO ( IOMode(..), hPutStr, hClose, openFile, stderr )
+\end{code}
+
+
+\begin{code}
+codeOutput :: Module
+ -> SDoc -- C stubs for foreign exported functions
+ -> SDoc -- Header file prototype for foreign exported functions
+ -> AbstractC -- Compiled abstract C
+ -> UniqSupply
+ -> IO ()
+codeOutput mod_name c_code h_code flat_abstractC ncg_uniqs
+ = -- You can have C (c_output) or assembly-language (ncg_output),
+ -- but not both. [Allowing for both gives a space leak on
+ -- flat_abstractC. WDP 94/10]
+
+ dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d >>
+ doOutput opt_ProduceS ncg_output_w >>
+
+ dumpIfSet opt_D_dump_foreign "Foreign export header file" stub_h_output_d >>
+ outputHStub opt_ProduceExportHStubs stub_h_output_w >>
+
+ dumpIfSet opt_D_dump_foreign "Foreign export stubs" stub_c_output_d >>
+ outputCStub mod_name opt_ProduceExportCStubs stub_c_output_w >>
+
+ dumpIfSet opt_D_dump_realC "Real C" c_output_d >>
+ doOutput opt_ProduceC c_output_w
+
+ where
+ (flat_absC_c, flat_absC_ncg) =
+ case (maybeToBool opt_ProduceC || opt_D_dump_realC,
+ maybeToBool opt_ProduceS || opt_D_dump_asm) of
+ (True, False) -> (flat_abstractC, absCNop)
+ (False, True) -> (absCNop, flat_abstractC)
+ (False, False) -> (absCNop, absCNop)
+ (True, True) -> error "ERROR: Can't do both .hc and .s at the same time"
+
+ -- C stubs for "foreign export"ed functions.
+ stub_c_output_d = pprCode CStyle c_code
+ stub_c_output_w = showSDoc stub_c_output_d
+
+ -- Header file protos for "foreign export"ed functions.
+ stub_h_output_d = pprCode CStyle h_code
+ stub_h_output_w = showSDoc stub_h_output_d
+
+ c_output_d = dumpRealC flat_absC_c
+ c_output_w = (\ f -> writeRealC f flat_absC_c)
+
+ -- Native code generation done here!
+#if OMIT_NATIVE_CODEGEN
+ ncg_output_d = error "*** GHC not built with a native-code generator ***"
+ ncg_output_w = ncg_output_d
+#else
+ ncg_output_d = nativeCodeGen flat_absC_ncg ncg_uniqs
+ ncg_output_w = (\ f -> printForAsm f ncg_output_d)
+#endif
+
+
+ -- don't use doOutput for dumping the f. export stubs
+ -- since it is more than likely that the stubs file will
+ -- turn out to be empty, in which case no file should be created.
+outputCStub mod_name switch ""
+ = return ()
+outputCStub mod_name switch doc_str
+ = case switch of
+ Nothing -> return ()
+ Just fname -> writeFile fname ("#include \"Rts.h\"\n#include \"RtsAPI.h\"\n"++rest)
+ where
+ rest = "#include "++show (moduleString mod_name ++ "_stub.h") ++ '\n':doc_str
+
+outputHStub switch ""
+ = return ()
+outputHStub switch doc_str
+ = case switch of
+ Nothing -> return ()
+ Just fname -> writeFile fname ("#include \"Rts.h\"\n"++doc_str)
+
+doOutput switch io_action
+ = case switch of
+ Nothing -> return ()
+ Just fname ->
+ openFile fname WriteMode >>= \ handle ->
+ io_action handle >>
+ hClose handle
+\end{code}
+
\begin{code}
module Constants (
- uNFOLDING_USE_THRESHOLD,
- uNFOLDING_CREATION_THRESHOLD,
- iNTERFACE_UNFOLD_THRESHOLD,
- lIBERATE_CASE_THRESHOLD,
- uNFOLDING_CHEAP_OP_COST,
- uNFOLDING_DEAR_OP_COST,
- uNFOLDING_NOREP_LIT_COST,
- uNFOLDING_CON_DISCOUNT_WEIGHT,
- uNFOLDING_KEENESS_FACTOR,
-
mAX_CONTEXT_REDUCTION_DEPTH,
mAX_TUPLE_SIZE,
mAX_CONTEXT_REDUCTION_DEPTH = (20 :: Int)
\end{code}
-\begin{code}
-uNFOLDING_USE_THRESHOLD = ( 8 :: Int)
-uNFOLDING_CREATION_THRESHOLD = (30 :: Int) -- Discounts can be big
-iNTERFACE_UNFOLD_THRESHOLD = (30 :: Int)
-lIBERATE_CASE_THRESHOLD = (10 :: Int)
-
-uNFOLDING_CHEAP_OP_COST = ( 1 :: Int)
-uNFOLDING_DEAR_OP_COST = ( 4 :: Int)
-uNFOLDING_NOREP_LIT_COST = ( 20 :: Int) -- Strings can be pretty big
-uNFOLDING_CON_DISCOUNT_WEIGHT = ( 3 :: Int)
-uNFOLDING_KEENESS_FACTOR = ( 2.0 :: Float)
-\end{code}
\begin{code}
-
-- specialised fun/thunk/constr closure types
mAX_SPEC_THUNK_SIZE = (MAX_SPEC_THUNK_SIZE :: Int)
mAX_SPEC_FUN_SIZE = (MAX_SPEC_FUN_SIZE :: Int)
#include "HsVersions.h"
-import IO ( IOMode(..), hPutStr, hClose, openFile, stderr )
+import IO ( hPutStr, stderr )
import HsSyn
import BasicTypes ( NewOrData(..) )
import ReadPrefix ( rdModule )
import Rename ( renameModule )
-import MkIface -- several functions
-import TcModule ( typecheckModule )
+import MkIface ( startIface, ifaceDecls, endIface )
+import TcModule ( TcResults(..), typecheckModule )
import Desugar ( deSugar )
import SimplCore ( core2core )
+import CoreLint ( endPass )
+import CoreTidy ( tidyCorePgm )
import CoreToStg ( topCoreBindsToStg )
-import StgSyn ( collectFinalStgBinders, pprStgBindingsWithSRTs )
+import StgSyn ( collectFinalStgBinders, pprStgBindings )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
-#if ! OMIT_NATIVE_CODEGEN
-import AsmCodeGen ( dumpRealAsm, writeRealAsm )
-#endif
+import CodeOutput ( codeOutput )
-import Module ( Module, moduleString )
+import Module ( ModuleName, moduleNameUserString )
import AbsCSyn ( absCNop )
-import AbsCUtils ( flattenAbsC )
import CmdLineOpts
import ErrUtils ( ghcExit, doIfSet, dumpIfSet )
import Maybes ( maybeToBool, MaybeErr(..) )
import Class ( classTyCon )
import UniqSupply ( mkSplitUniqSupply )
-import PprAbsC ( dumpRealC, writeRealC )
import FiniteMap ( emptyFM )
import Outputable
import Char ( isSpace )
hPutStr stderr compiler_version >>
hPutStr stderr ", for Haskell 98\n") >>
- -- ******* READER
+ -------------------------- Reader ----------------
show_pass "Reader" >>
_scc_ "Reader"
rdModule >>= \ (mod_name, rdr_module) ->
- dumpIfSet opt_D_dump_rdr "Reader" (ppr rdr_module) >>
-
dumpIfSet opt_D_source_stats "Source Statistics"
(ppSourceStats False rdr_module) >>
-- UniqueSupplies for later use (these are the only lower case uniques)
--- _scc_ "spl-rn"
mkSplitUniqSupply 'r' >>= \ rn_uniqs -> -- renamer
--- _scc_ "spl-tc"
mkSplitUniqSupply 'a' >>= \ tc_uniqs -> -- typechecker
--- _scc_ "spl-ds"
mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer
--- _scc_ "spl-sm"
- mkSplitUniqSupply 's' >>= \ sm_uniqs -> -- core-to-core simplifier
--- _scc_ "spl-c2s"
+ mkSplitUniqSupply 'r' >>= \ ru_uniqs -> -- rules
mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg
--- _scc_ "spl-st"
+ mkSplitUniqSupply 'u' >>= \ tidy_uniqs -> -- tidy up
mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes
--- _scc_ "spl-absc"
- mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener
--- _scc_ "spl-ncg"
mkSplitUniqSupply 'n' >>= \ ncg_uniqs -> -- native-code generator
- -- ******* RENAMER
+ -------------------------- Rename ----------------
show_pass "Renamer" >>
_scc_ "Renamer"
- renameModule rn_uniqs rdr_module >>=
- \ maybe_rn_stuff ->
+ renameModule rn_uniqs rdr_module >>= \ maybe_rn_stuff ->
case maybe_rn_stuff of {
Nothing -> -- Hurrah! Renamer reckons that there's no need to
-- go any further
reportCompile mod_name "Compilation NOT required!" >>
return ();
- Just (rn_mod, iface_file_stuff, rn_name_supply, imported_modules) ->
+ Just (this_mod, rn_mod, iface_file_stuff, rn_name_supply, imported_modules) ->
-- Oh well, we've got to recompile for real
+ -------------------------- Start interface file ----------------
-- Safely past renaming: we can start the interface file:
-- (the iface file is produced incrementally, as we have
-- the information that we need...; we use "iface<blah>")
-- "endIface" finishes the job.
- startIface mod_name >>= \ if_handle ->
- ifaceMain if_handle iface_file_stuff >>
+ startIface this_mod iface_file_stuff >>= \ if_handle ->
- -- ******* TYPECHECKER
+ -------------------------- Typechecking ----------------
show_pass "TypeCheck" >>
_scc_ "TypeCheck"
- typecheckModule tc_uniqs rn_name_supply iface_file_stuff rn_mod
- >>= \ maybe_tc_stuff ->
+ typecheckModule tc_uniqs rn_name_supply
+ iface_file_stuff rn_mod >>= \ maybe_tc_stuff ->
case maybe_tc_stuff of {
Nothing -> ghcExit 1; -- Type checker failed
- Just (all_binds,
- local_tycons, local_classes, inst_info,
- fo_decls,
- global_env,
- global_ids) ->
+ Just (tc_results@(TcResults {tc_tycons = local_tycons,
+ tc_classes = local_classes,
+ tc_insts = inst_info })) ->
+
- -- ******* DESUGARER
- show_pass "DeSugar" >>
+ -------------------------- Desugaring ----------------
_scc_ "DeSugar"
- deSugar ds_uniqs global_env mod_name all_binds fo_decls >>= \ (desugared, h_code, c_code) ->
+ deSugar this_mod ds_uniqs tc_results >>= \ (desugared, rules, h_code, c_code) ->
- -- ******* CORE-TO-CORE SIMPLIFICATION
- show_pass "Core2Core" >>
+ -------------------------- Main Core-language transformations ----------------
_scc_ "Core2Core"
- let
- local_data_tycons = filter isDataTyCon local_tycons
- in
- core2core core_cmds mod_name local_classes
- sm_uniqs desugared
- >>=
- \ simplified ->
+ core2core core_cmds desugared rules >>= \ (simplified, imp_rule_ids) ->
+
+ -- Do the final tidy-up
+ tidyCorePgm tidy_uniqs this_mod
+ simplified imp_rule_ids >>= \ (tidy_binds, tidy_imp_rule_ids) ->
- -- ******* STG-TO-STG SIMPLIFICATION
+ -------------------------- Convert to STG code -------------------------------
show_pass "Core2Stg" >>
_scc_ "Core2Stg"
let
- stg_binds = topCoreBindsToStg c2s_uniqs simplified
+ stg_binds = topCoreBindsToStg c2s_uniqs tidy_binds
in
+ -------------------------- Simplify STG code -------------------------------
show_pass "Stg2Stg" >>
_scc_ "Stg2Stg"
- stg2stg stg_cmds mod_name st_uniqs stg_binds
- >>=
- \ (stg_binds2, cost_centre_info) ->
+ stg2stg stg_cmds this_mod st_uniqs stg_binds >>= \ (stg_binds2, cost_centre_info) ->
- dumpIfSet opt_D_dump_stg "STG syntax:"
- (pprStgBindingsWithSRTs stg_binds2) >>
+ -------------------------- Interface file -------------------------------
-- Dump instance decls and type signatures into the interface file
+ _scc_ "Interface"
let
final_ids = collectFinalStgBinders (map fst stg_binds2)
in
- _scc_ "Interface"
- ifaceDecls if_handle local_tycons local_classes inst_info final_ids simplified >>
+ ifaceDecls if_handle local_tycons local_classes
+ inst_info final_ids tidy_binds imp_rule_ids >>
endIface if_handle >>
- -- We are definitely done w/ interface-file stuff at this point:
- -- (See comments near call to "startIface".)
+ -- We are definitely done w/ interface-file stuff at this point:
+ -- (See comments near call to "startIface".)
+
- -- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C!
+ -------------------------- Code generation -------------------------------
show_pass "CodeGen" >>
_scc_ "CodeGen"
- let
- all_local_data_tycons = filter isDataTyCon (map classTyCon local_classes)
- ++ local_data_tycons
- -- Generate info tables for the data constrs arising
- -- from class decls as well
-
- all_tycon_specs = emptyFM -- Not specialising tycons any more
+ codeGen this_mod imported_modules
+ cost_centre_info
+ local_tycons local_classes
+ stg_binds2 >>= \ abstractC ->
- abstractC = codeGen mod_name -- module name for CC labelling
- cost_centre_info
- imported_modules -- import names for CC registering
- all_local_data_tycons -- type constructors generated locally
- all_tycon_specs -- tycon specialisations
- stg_binds2
- flat_abstractC = flattenAbsC fl_uniqs abstractC
- in
- dumpIfSet opt_D_dump_absC "Abstract C" (dumpRealC abstractC) >>
-
- show_pass "CodeOutput" >>
+ -------------------------- Code output -------------------------------
+ show_pass "CodeOutput" >>
_scc_ "CodeOutput"
- -- You can have C (c_output) or assembly-language (ncg_output),
- -- but not both. [Allowing for both gives a space leak on
- -- flat_abstractC. WDP 94/10]
- let
- (flat_absC_c, flat_absC_ncg) =
- case (maybeToBool opt_ProduceC || opt_D_dump_realC,
- maybeToBool opt_ProduceS || opt_D_dump_asm) of
- (True, False) -> (flat_abstractC, absCNop)
- (False, True) -> (absCNop, flat_abstractC)
- (False, False) -> (absCNop, absCNop)
- (True, True) -> error "ERROR: Can't do both .hc and .s at the same time"
-
- -- C stubs for "foreign export"ed functions.
- stub_c_output_d = pprCode CStyle c_code
- stub_c_output_w = showSDoc stub_c_output_d
-
- -- Header file protos for "foreign export"ed functions.
- stub_h_output_d = pprCode CStyle h_code
- stub_h_output_w = showSDoc stub_h_output_d
-
- c_output_d = dumpRealC flat_absC_c
- c_output_w = (\ f -> writeRealC f flat_absC_c)
-
-#if OMIT_NATIVE_CODEGEN
- ncg_output_d = error "*** GHC not built with a native-code generator ***"
- ncg_output_w = ncg_output_d
-#else
- ncg_output_d = dumpRealAsm flat_absC_ncg ncg_uniqs
- ncg_output_w = (\ f -> writeRealAsm f flat_absC_ncg ncg_uniqs)
-#endif
- in
-
- dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d >>
- doOutput opt_ProduceS ncg_output_w >>
-
- dumpIfSet opt_D_dump_foreign "Foreign export header file" stub_h_output_d >>
- outputHStub opt_ProduceExportHStubs stub_h_output_w >>
+ codeOutput this_mod c_code h_code abstractC ncg_uniqs >>
- dumpIfSet opt_D_dump_foreign "Foreign export stubs" stub_c_output_d >>
- outputCStub mod_name opt_ProduceExportCStubs stub_c_output_w >>
-
- dumpIfSet opt_D_dump_realC "Real C" c_output_d >>
- doOutput opt_ProduceC c_output_w >>
+ -------------------------- Final report -------------------------------
reportCompile mod_name (showSDoc (ppSourceStats True rdr_module)) >>
ghcExit 0
then \ what -> hPutStr stderr ("*** "++what++":\n")
else \ what -> return ()
- doOutput switch io_action
- = case switch of
- Nothing -> return ()
- Just fname ->
- openFile fname WriteMode >>= \ handle ->
- io_action handle >>
- hClose handle
-
- -- don't use doOutput for dumping the f. export stubs
- -- since it is more than likely that the stubs file will
- -- turn out to be empty, in which case no file should be created.
- outputCStub mod_name switch "" = return ()
- outputCStub mod_name switch doc_str
- = case switch of
- Nothing -> return ()
- Just fname -> writeFile fname ("#include \"Rts.h\"\n#include \"RtsAPI.h\"\n"++rest)
- where
- rest = "#include "++show (moduleString mod_name ++ "_stub.h") ++ '\n':doc_str
-
- outputHStub switch "" = return ()
- outputHStub switch doc_str
- = case switch of
- Nothing -> return ()
- Just fname -> writeFile fname ("#include \"Rts.h\"\n"++doc_str)
-
ppSourceStats short (HsModule name version exports imports decls src_loc)
= (if short then hcat else vcat)
(map pp_val
sig_info (Sig _ _ _) = (1,0,0,0)
sig_info (ClassOpSig _ _ _ _) = (0,1,0,0)
- sig_info (SpecSig _ _ _ _) = (0,0,1,0)
+ sig_info (SpecSig _ _ _) = (0,0,1,0)
sig_info (InlineSig _ _) = (0,0,0,1)
sig_info _ = (0,0,0,0)
- import_info (ImportDecl _ qual as spec _)
+ import_info (ImportDecl _ _ qual as spec _)
= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
qual_info False = 0
qual_info True = 1
= (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds})
data_info other = (0,0)
- class_info (ClassDecl _ _ _ meth_sigs def_meths _ _ _ _)
+ class_info (ClassDecl _ _ _ meth_sigs def_meths _ _ _ _ _)
= case count_sigs meth_sigs of
(_,classops,_,_) ->
(classops, addpr (count_monobinds def_meths))
\end{code}
\begin{code}
-reportCompile :: Module -> String -> IO ()
+reportCompile :: ModuleName -> String -> IO ()
#if REPORT_TO_MOTHERLODE && __GLASGOW_HASKELL__ >= 303
reportCompile mod_name info
| not opt_ReportCompile = return ()
| otherwise = (do
sock <- udpSocket 0
addr <- motherShip
- sendTo sock (moduleString mod_name ++ ';': compiler_version ++ ';': os ++ ';':arch ++ '\n':' ':info ++ "\n") addr
+ sendTo sock (moduleNameUserString mod_name ++ ';': compiler_version ++
+ ';': os ++ ';':arch ++ '\n':' ':info ++ "\n") addr
return ()) `catch` (\ _ -> return ())
motherShip :: IO SockAddr
\begin{code}
module MkIface (
- startIface, endIface,
- ifaceMain,
- ifaceDecls
+ startIface, endIface, ifaceDecls
) where
#include "HsVersions.h"
hClose, hPutStrLn, IOMode(..) )
import HsSyn
-import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..),
- StrictnessMark(..)
- )
+import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) )
import RnMonad
import RnEnv ( availName )
import TcInstUtil ( InstInfo(..) )
-import WorkWrap ( getWorkerIdAndCons )
+import WorkWrap ( getWorkerId )
import CmdLineOpts
-import Id ( Id, idType, idInfo, omitIfaceSigForId,
+import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId,
getIdSpecialisation
)
import Var ( isId )
import VarSet
-import DataCon ( dataConSig, dataConFieldLabels, dataConStrictMarks )
+import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo ( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePragInfo,
arityInfo, ppArityInfo,
strictnessInfo, ppStrictnessInfo,
- cafInfo, ppCafInfo,
+ cafInfo, ppCafInfo, specInfo,
cprInfo, ppCprInfo,
workerExists, workerInfo, isBottomingStrictness
)
-import CoreSyn ( CoreExpr, CoreBind, Bind(..) )
-import CoreUtils ( exprSomeFreeVars )
-import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..),
- Unfolding, okToUnfoldInHiFile )
-import Module ( moduleString, pprModule, pprModuleBoot )
+import CoreSyn ( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars )
+import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
+import CoreUnfold ( calcUnfoldingGuidance, okToUnfoldInHiFile, couldBeSmallEnoughToInline )
+import Module ( moduleString, pprModule, pprModuleName )
import Name ( isLocallyDefined, isWiredInName, nameRdrName, nameModule,
- isExported,
Name, NamedThing(..)
)
import OccName ( OccName, pprOccName )
tyConTheta, tyConTyVars, tyConDataCons
)
import Class ( Class, classBigSig )
-import SpecEnv ( specEnvToList )
import FieldLabel ( fieldLabelName, fieldLabelType )
import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType,
Type, ThetaType
)
import PprType
-import PprCore ( pprIfaceUnfolding )
+import PprCore ( pprIfaceUnfolding, pprCoreRule )
+import Rules ( pprProtoCoreRule, ProtoCoreRule(..) )
import Bag ( bagToList, isEmptyBag )
import Maybes ( catMaybes, maybeToBool )
import UniqFM ( lookupUFM, listToUFM )
import UniqSet ( uniqSetToList )
import Util ( sortLt, mapAccumL )
+import Bag
import Outputable
\end{code}
to the handle provided by @startIface@.
\begin{code}
-startIface :: Module
+startIface :: Module -> InterfaceDetails
-> IO (Maybe Handle) -- Nothing <=> don't do an interface
-ifaceMain :: Maybe Handle
- -> InterfaceDetails
- -> IO ()
-
-
ifaceDecls :: Maybe Handle
-> [TyCon] -> [Class]
-> Bag InstInfo
-> [Id] -- Ids used at code-gen time; they have better pragma info!
-> [CoreBind] -- In dependency order, later depend on earlier
+ -> [ProtoCoreRule] -- Rules
-> IO ()
endIface :: Maybe Handle -> IO ()
\end{code}
\begin{code}
-startIface mod
+startIface mod (has_orphans, import_usages, ExportEnv avails fixities)
= case opt_ProduceHi of
- Nothing -> return Nothing -- not producing any .hi file
- Just fn -> do
+ Nothing -> return Nothing ; -- not producing any .hi file
+
+ Just fn -> do
if_hdl <- openFile fn WriteMode
- hPutStr if_hdl ("__interface " ++ moduleString mod ++ ' ':show (opt_HiVersion :: Int))
- hPutStrLn if_hdl " where"
+ hPutStr if_hdl ("__interface " ++ moduleString mod)
+ hPutStr if_hdl (' ' : show (opt_HiVersion :: Int) ++ orphan_indicator)
+ hPutStrLn if_hdl " where"
+ ifaceExports if_hdl avails
+ ifaceImports if_hdl import_usages
+ ifaceFixities if_hdl fixities
return (Just if_hdl)
+ where
+ orphan_indicator | has_orphans = " !"
+ | otherwise = ""
endIface Nothing = return ()
endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl
\begin{code}
-ifaceMain Nothing iface_stuff = return ()
-ifaceMain (Just if_hdl)
- (import_usages, ExportEnv avails fixities, instance_modules)
- = do
- ifaceImports if_hdl import_usages
- ifaceInstanceModules if_hdl instance_modules
- ifaceExports if_hdl avails
- ifaceFixities if_hdl fixities
- return ()
-
-ifaceDecls Nothing tycons classes inst_info final_ids simplified = return ()
+ifaceDecls Nothing tycons classes inst_info final_ids simplified rules = return ()
ifaceDecls (Just hdl)
tycons classes
inst_infos
final_ids binds
+ orphan_rules -- Rules defined locally for an Id that is *not* defined locally
| null_decls = return ()
-- You could have a module with just (re-)exports/instances in it
| otherwise
= ifaceClasses hdl classes >>
- ifaceInstances hdl inst_infos >>= \ needed_ids ->
+ ifaceInstances hdl inst_infos >>= \ inst_ids ->
ifaceTyCons hdl tycons >>
- ifaceBinds hdl needed_ids final_ids binds >>
+ ifaceBinds hdl (inst_ids `unionVarSet` orphan_rule_ids)
+ final_ids binds >>= \ emitted_ids ->
+ ifaceRules hdl orphan_rules emitted_ids >>
return ()
where
+ orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
+ | ProtoCoreRule _ _ rule <- orphan_rules]
+
null_decls = null binds &&
null tycons &&
null classes &&
- isEmptyBag inst_infos
+ isEmptyBag inst_infos &&
+ null orphan_rules
\end{code}
\begin{code}
ifaceImports if_hdl import_usages
= hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
where
- upp_uses (m, mv, whats_imported)
- = ptext SLIT("import ") <>
- hsep [pprModule m, pprModuleBoot m, int mv, dcolon,
+ upp_uses (m, mv, has_orphans, whats_imported)
+ = hsep [ptext SLIT("import"), pprModuleName m,
+ int mv, pp_orphan,
upp_import_versions whats_imported
] <> semi
+ where
+ pp_orphan | has_orphans = ptext SLIT("!")
+ | otherwise = empty
-- Importing the whole module is indicated by an empty list
upp_import_versions Everything = empty
-- For imported versions we do print the version number
upp_import_versions (Specifically nvs)
- = hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- sort_versions nvs ]
-
-ifaceInstanceModules if_hdl [] = return ()
-ifaceInstanceModules if_hdl imods
- = let sorted = sortLt (<) imods
- lines = map (\m -> ptext SLIT("__instimport ") <> pprModule m <>
- ptext SLIT(" ;")) sorted
+ = dcolon <+> hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- sort_versions nvs ]
+
+ifaceModuleDeps if_hdl [] = return ()
+ifaceModuleDeps if_hdl mod_deps
+ = let
+ lines = map ppr_mod_dep mod_deps
+ ppr_mod_dep (mod, contains_orphans)
+ | contains_orphans = pprModuleName mod <+> ptext SLIT("!")
+ | otherwise = pprModuleName mod
in
- printForIface if_hdl (vcat lines) >>
+ printForIface if_hdl (ptext SLIT("__depends") <+> vcat lines <> ptext SLIT(" ;")) >>
hPutStr if_hdl "\n"
ifaceExports if_hdl [] = return ()
do_one_module :: (Module, [AvailInfo]) -> SDoc
do_one_module (mod_name, avails@(avail1:_))
= ptext SLIT("__export ") <>
- hsep [pprModuleBoot (nameModule (availName avail1)),
- pprModule mod_name,
+ hsep [pprModule mod_name,
hsep (map upp_avail (sortLt lt_avail avails))
] <> semi
ifaceFixities if_hdl [] = return ()
ifaceFixities if_hdl fixities
= hPutCol if_hdl upp_fixity fixities
-\end{code}
+
+ifaceRules if_hdl rules emitted
+ | null orphan_rule_pretties && null local_id_pretties
+ = return ()
+ | otherwise
+ = do printForIface if_hdl (vcat [
+ ptext SLIT("{-## __R"),
+
+ vcat orphan_rule_pretties,
+
+ vcat local_id_pretties,
+
+ ptext SLIT("##-}")
+ ])
+
+ return ()
+ where
+ orphan_rule_pretties = [ pprCoreRule (Just fn) rule <+> semi
+ | ProtoCoreRule _ fn rule <- rules
+ ]
+ local_id_pretties = [ pprCoreRule (Just fn) rule <+> semi
+ | fn <- varSetElems emitted,
+ rule <- rulesRules (getIdSpecialisation fn),
+ all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
+ -- Spit out a rule only if all its lhs free vars are eemitted
+ ]
+\end{code}
%************************************************************************
%* *
-> Bool -- True <=> recursive, so don't print unfolding
-> Id
-> CoreExpr -- The Id's right hand side
- -> Maybe (SDoc, IdSet) -- The emitted stuff, plus a possibly-augmented set of needed Ids
+ -> Maybe (SDoc, IdSet) -- The emitted stuff, plus any *extra* needed Ids
ifaceId get_idinfo needed_ids is_rec id rhs
| not (id `elemVarSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId]
- (isExported id && not (omitIfaceSigForId id))) -- or exported and not to be omitted
+ (isUserExportedId id && not (omitIfaceSigForId id))) -- or exported and not to be omitted
= Nothing -- Well, that was easy!
ifaceId get_idinfo needed_ids is_rec id rhs
= Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
where
idinfo = get_idinfo id
- inline_pragma = inlinePragInfo idinfo
ty_pretty = pprType (idType id)
sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty]
cpr_pretty,
strict_pretty,
unfold_pretty,
- spec_pretty,
ptext SLIT("##-}")]
------------ Arity --------------
strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty
wrkr_pretty | not has_worker = empty
- | null con_list = ppr work_id
- | otherwise = ppr work_id <+>
- braces (hsep (map ppr con_list))
+ | otherwise = ppr work_id
-- (Just work_id) = work_info
-- Temporary fix. We can't use the worker id saved by the w/w
-- pass because later optimisations may have changed it. So try
-- to snaffle from the wrapper code again ...
- (work_id, wrapper_cons) = getWorkerIdAndCons id rhs
- con_list = uniqSetToList wrapper_cons
+ work_id = getWorkerId id rhs
------------ Unfolding --------------
- unfold_pretty | show_unfold = unfold_herald <+> pprIfaceUnfolding rhs
- | otherwise = empty
-
- show_unfold = not has_worker && -- Not unnecessary
- not bottoming_fn && -- Not necessary
- unfolding_needed -- Not dangerous
-
- unfolding_needed = case inline_pragma of
- IMustBeINLINEd -> definitely_ok_to_unfold
- IWantToBeINLINEd -> definitely_ok_to_unfold
- NoInlinePragInfo -> rhs_is_small
- other -> False
-
+ inline_pragma = inlinePragInfo idinfo
+ dont_inline = case inline_pragma of
+ IMustNotBeINLINEd -> True
+ IAmALoopBreaker -> True
+ other -> False
- unfold_herald = case inline_pragma of
- NoInlinePragInfo -> ptext SLIT("__u")
- other -> ppr inline_pragma
+ unfold_pretty | show_unfold = ptext SLIT("__u") <+> pprIfaceUnfolding rhs
+ | otherwise = empty
- rhs_is_small = case calcUnfoldingGuidance opt_InterfaceUnfoldThreshold rhs of
- UnfoldNever -> False -- Too big
- other -> definitely_ok_to_unfold -- Small enough
+ show_unfold = not has_worker && -- Not unnecessary
+ not bottoming_fn && -- Not necessary
+ not dont_inline &&
+ rhs_is_small && -- Small enough
+ okToUnfoldInHiFile rhs -- No casms etc
- definitely_ok_to_unfold = okToUnfoldInHiFile rhs
+ rhs_is_small = couldBeSmallEnoughToInline (calcUnfoldingGuidance opt_UF_HiFileThreshold rhs)
------------ Specialisations --------------
- spec_list = specEnvToList (getIdSpecialisation id)
- spec_pretty = hsep (map pp_spec spec_list)
- pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("__P"),
- if null tyvars then ptext SLIT("[ ]")
- else brackets (interppSP tyvars),
- -- The lexer interprets "[]" as a CONID. Sigh.
- hsep (map pprParendType tys),
- ptext SLIT("="),
- pprIfaceUnfolding rhs
- ]
+ spec_info = specInfo idinfo
------------ Extra free Ids --------------
- new_needed_ids = (needed_ids `minusVarSet` unitVarSet id) `unionVarSet`
- extra_ids
-
- extra_ids | opt_OmitInterfacePragmas = emptyVarSet
- | otherwise = worker_ids `unionVarSet`
- unfold_ids `unionVarSet`
- spec_ids
+ new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
+ | otherwise = worker_ids `unionVarSet`
+ unfold_ids `unionVarSet`
+ spec_ids
- worker_ids | has_worker && interesting work_id = unitVarSet work_id
+ worker_ids | has_worker && interestingId work_id = unitVarSet work_id
-- Conceivably, the worker might come from
-- another module
| otherwise = emptyVarSet
- spec_ids = foldr add emptyVarSet spec_list
- where
- add (_, _, rhs) = unionVarSet (find_fvs rhs)
+ spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
unfold_ids | show_unfold = find_fvs rhs
| otherwise = emptyVarSet
- find_fvs expr = free_vars
- where
- free_vars = exprSomeFreeVars interesting expr
+ find_fvs expr = exprSomeFreeVars interestingId expr
- interesting id = isId id && isLocallyDefined id &&
- not (omitIfaceSigForId id)
+interestingId id = isId id && isLocallyDefined id &&
+ not (omitIfaceSigForId id)
\end{code}
\begin{code}
-> IdSet -- These Ids are needed already
-> [Id] -- Ids used at code-gen time; they have better pragma info!
-> [CoreBind] -- In dependency order, later depend on earlier
- -> IO ()
+ -> IO IdSet -- Set of Ids actually spat out
ifaceBinds hdl needed_ids final_ids binds
- = mapIO (printForIface hdl) pretties >>
- hPutStr hdl "\n"
+ = mapIO (printForIface hdl) (bagToList pretties) >>
+ hPutStr hdl "\n" >>
+ return emitted
where
final_id_map = listToUFM [(id,id) | id <- final_ids]
get_idinfo id = case lookupUFM final_id_map id of
Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
idInfo id
- pretties = go needed_ids (reverse binds) -- Reverse so that later things will
- -- provoke earlier ones to be emitted
- go needed [] = if not (isEmptyVarSet needed) then
- pprTrace "ifaceBinds: free vars:"
- (sep (map ppr (varSetElems needed))) $
- []
- else
- []
+ (pretties, emitted) = go needed_ids (reverse binds) emptyBag emptyVarSet
+ -- Reverse so that later things will
+ -- provoke earlier ones to be emitted
+ go needed [] pretties emitted
+ | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
+ (sep (map ppr (varSetElems needed)))
+ (pretties, emitted)
+ | otherwise = (pretties, emitted)
- go needed (NonRec id rhs : binds)
+ go needed (NonRec id rhs : binds) pretties emitted
= case ifaceId get_idinfo needed False id rhs of
- Nothing -> go needed binds
- Just (pretty, needed') -> pretty : go needed' binds
+ Nothing -> go needed binds pretties emitted
+ Just (pretty, extras) -> let
+ needed' = (needed `unionVarSet` extras) `delVarSet` id
+ -- 'extras' can include the Id itself via a rule
+ emitted' = emitted `extendVarSet` id
+ in
+ go needed' binds (pretty `consBag` pretties) emitted'
-- Recursive groups are a bit more of a pain. We may only need one to
-- start with, but it may call out the next one, and so on. So we
-- have to look for a fixed point.
- go needed (Rec pairs : binds)
- = pretties ++ go needed'' binds
+ go needed (Rec pairs : binds) pretties emitted
+ = go needed' binds pretties' emitted'
where
- (needed', pretties) = go_rec needed pairs
- needed'' = needed' `minusVarSet` mkVarSet (map fst pairs)
- -- Later ones may spuriously cause earlier ones to be "needed" again
+ (new_pretties, new_emitted, extras) = go_rec needed pairs
+ pretties' = new_pretties `unionBags` pretties
+ needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
+ emitted' = emitted `unionVarSet` new_emitted
- go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [SDoc])
+ go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag SDoc, IdSet, IdSet)
go_rec needed pairs
- | null pretties = (needed, [])
- | otherwise = (final_needed, more_pretties ++ pretties)
+ | null pretties = (emptyBag, emptyVarSet, emptyVarSet)
+ | otherwise = (more_pretties `unionBags` listToBag pretties,
+ more_emitted `unionVarSet` mkVarSet emitted,
+ more_extras `unionVarSet` extras)
where
- reduced_pairs = [pair | (pair,Nothing) <- pairs `zip` maybes]
- pretties = catMaybes maybes
- (needed', maybes) = mapAccumL do_one needed pairs
- (final_needed, more_pretties) = go_rec needed' reduced_pairs
-
- do_one needed (id,rhs) = case ifaceId get_idinfo needed True id rhs of
- Nothing -> (needed, Nothing)
- Just (pretty, needed') -> (needed', Just pretty)
+ maybes = map do_one pairs
+ emitted = [id | ((id,_), Just _) <- pairs `zip` maybes]
+ reduced_pairs = [pair | (pair, Nothing) <- pairs `zip` maybes]
+ (pretties, extras_s) = unzip (catMaybes maybes)
+ extras = unionVarSets extras_s
+ (more_pretties, more_emitted, more_extras) = go_rec extras reduced_pairs
+
+ do_one (id,rhs) = ifaceId get_idinfo needed True id rhs
\end{code}
lt_lexical a1 a2 = getName a1 `lt_name` getName a2
lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
-lt_imp_vers (m1,_,_) (m2,_,_) = m1 < m2
+lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2
sort_versions vs = sortLt lt_vers vs
%
\begin{code}
-module AsmCodeGen ( writeRealAsm, dumpRealAsm ) where
+module AsmCodeGen ( nativeCodeGen ) where
#include "HsVersions.h"
So, here we go:
\begin{code}
-writeRealAsm :: Handle -> AbstractC -> UniqSupply -> IO ()
-writeRealAsm handle absC us
- = -- _scc_ "writeRealAsm"
- printForAsm handle (initUs_ us (runNCG absC))
-
-dumpRealAsm :: AbstractC -> UniqSupply -> SDoc
-dumpRealAsm absC us = initUs_ us (runNCG absC)
+nativeCodeGen :: AbstractC -> UniqSupply -> SDoc
+nativeCodeGen absC us = initUs_ us (runNCG absC)
runNCG absC
= genCodeAbstractC absC `thenUs` \ treelists ->
module U_gdexp,
module U_match,
module U_qid,
+ module U_rulevar,
module U_tree,
module U_ttype
) where
import U_qid
import U_tree
import U_ttype
+import U_rulevar
import UgenUtil
\end{code}
\begin{code}
type UgnM a
- = (FastString,Module,SrcLoc) -- file, module and src_loc carried down
+ = (FastString,SrcLoc) -- file, and src_loc carried down
-> IO a
{-# INLINE returnUgn #-}
y z stuff
initUgn :: UgnM a -> IO a
-initUgn action = action (SLIT(""),mkSrcModule "",noSrcLoc)
+initUgn action = action (SLIT(""),noSrcLoc)
ioToUgnM :: IO a -> UgnM a
ioToUgnM x stuff = x
\begin{code}
setSrcFileUgn :: FastString -> UgnM a -> UgnM a
-setSrcFileUgn file action stuff@(_,mod,loc) = action (file,mod,loc)
+setSrcFileUgn file action stuff@(_,loc) = action (file,loc)
getSrcFileUgn :: UgnM FastString
-getSrcFileUgn stuff@(file,mod,loc) = returnUgn file stuff
-
-setSrcModUgn :: Module -> UgnM a -> UgnM a
-setSrcModUgn mod action stuff@(file,_,loc) = action (file,mod,loc)
-
-getSrcModUgn :: UgnM Module
-getSrcModUgn stuff@(file,mod,loc) = returnUgn mod stuff
+getSrcFileUgn stuff@(file,loc) = returnUgn file stuff
mkSrcLocUgn :: U_long -> (SrcLoc -> UgnM a) -> UgnM a
-mkSrcLocUgn ln action (file,mod,_)
- = action loc (file,mod,loc)
+mkSrcLocUgn ln action (file,_)
+ = action loc (file,loc)
where
loc = mkSrcLoc file ln
getSrcLocUgn :: UgnM SrcLoc
-getSrcLocUgn stuff@(file,mod,loc) = returnUgn loc stuff
+getSrcLocUgn stuff@(file,loc) = returnUgn loc stuff
\end{code}
/* user-specified pragmas:XXXX */
vspec_uprag : < gvspec_id : qid;
- gvspec_tys : list;
+ gvspec_tys : list; /* Of type */
gvspec_line : long; >;
vspec_ty_and_id : < gvspec_ty : ttype;
gvspec_tyid : maybe; /* nil or singleton */ >;
- ispec_uprag : < gispec_clas : qid;
- gispec_ty : ttype;
+ ispec_uprag : < gispec_ty : ttype;
gispec_line : long; >;
inline_uprag: < ginline_id : qid;
gdspec_tys : list;
gdspec_line : long; >;
+ /* Transformation rule */
+ rule_prag : < grule_name : hstring;
+ grule_forall : list;
+ grule_lhs : VOID_STAR; /* Really tree, but mutual recursion problem in C */
+ grule_rhs : VOID_STAR; /* Really tree, but mutual recursion problem in C */
+ grule_line : long; >;
end;
PUSH_STATE(UserPragma);
RETURN(INLINE_UPRAGMA);
}
+<Code,GlaExt>"{-#"{WS}*"RULES" {
+ PUSH_STATE(Code); /* I'm not sure about this */
+ RETURN(RULES_UPRAGMA);
+ }
<Code,GlaExt>"{-#"{WS}*"inline" {
PUSH_STATE(UserPragma);
RETURN(INLINE_UPRAGMA);
nested_comments = 1; comment_start = hsplineno;
PUSH_STATE(Comment);
}
-<UserPragma>"#-}" { POP_STATE; RETURN(END_UPRAGMA); }
+<Code,GlaExt,UserPragma>"#-}" { POP_STATE; RETURN(END_UPRAGMA); }
%{
/*
entidt uentid;
id uid;
qid uqid;
+ rulevar urulevar;
literal uliteral;
maybe umaybe;
either ueither;
**********************************************************************/
%token INTERFACE_UPRAGMA SPECIALISE_UPRAGMA
-%token INLINE_UPRAGMA NOINLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
+%token INLINE_UPRAGMA NOINLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA RULES_UPRAGMA
%token END_UPRAGMA
%token SOURCE_UPRAGMA
rbinds rbinds1 rpats rpats1 list_exps list_rest
qvarsk qvars_list
constrs fields conargatypes
- tautypes atypes
- types_and_maybe_ids
+ tautypes polytypes atypes
pats simple_context simple_context_list
export_list enames
import_list inames
impdecls maybeimpdecls impdecl
dtyclses dtycls_list
gdrhs gdpat
- lampats cexps gd texps
- tyvars1 constr_context forall
+ lampats aexps gd texps
+ var_list constr_context forall
+ rule_forall rule_var_list
%type <umatch> alt
patk bpatk apatck conpatk
+%type <urulevar> rule_var
+
%type <uid> MINUS PLUS DARROW AS LAZY
VARID CONID VARSYM CONSYM
var con varop conop op
%type <ubinding> topdecl topdecls letdecls
typed datad newtd classd instd defaultd foreignd
decl decls non_empty_decls fixdecl fix_op fix_ops valdef
- maybe_where where_body type_and_maybe_id
+ maybe_where where_body
+ ruled rules rule
%type <uttype> polytype
conargatype conapptype
%type <ulong> commas importkey get_line_no
unsafe_flag callconv
+
/**********************************************************************
* *
* *
| instd { $$ = $1; FN = NULL; SAMEFN = 0; }
| defaultd { $$ = $1; FN = NULL; SAMEFN = 0; }
| foreignd { $$ = $1; FN = NULL; SAMEFN = 0; }
+ | ruled { $$ = $1; FN = NULL; SAMEFN = 0; }
| decl { $$ = $1; }
;
+/* *********************************************************** */
+/* Transformation rules */
+
+ruled : RULES_UPRAGMA rules END_UPRAGMA { $$ = $2; }
+ ;
+
+rules : /* empty */ { $$ = mknullbind(); }
+ | rule { $$ = $1; }
+ | rule SEMI rules { $$ = mkabind($1,$3); }
+ | SEMI rules { $$ = $2; }
+ ;
+
+rule : STRING rule_forall fexp
+ EQUAL get_line_no exp { $$ = mkrule_prag($1,$2,$3,$6,$5); }
+
+rule_forall : FORALL rule_var_list DOT { $$ = $2; }
+ | /* Empty */ { $$ = Lnil; }
+ ;
+
+rule_var_list : /* Empty */ { $$ = Lnil; }
+ | rule_var { $$ = lsing($1); }
+ | rule_var COMMA rule_var_list { $$ = mklcons($1,$3); }
+ ;
+
+rule_var : varid { $$ = mkprulevar( $1 ); }
+ | varid DCOLON polytype { $$ = mkprulevarsig( $1, $3 ); }
+ ;
+
+/* *********************************************************** */
+
typed : typekey simple_con_app EQUAL tautype { $$ = mknbind($2,$4,startlineno); }
;
Have left out the case specialising to an overloaded type.
Let's get real, OK? (WDP)
*/
- | SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
+ | SPECIALISE_UPRAGMA qvark DCOLON polytypes END_UPRAGMA
{
$$ = mkvspec_uprag($2, $4, startlineno);
FN = NULL; SAMEFN = 0;
}
- | SPECIALISE_UPRAGMA INSTANCE gtycon atype END_UPRAGMA
+ | SPECIALISE_UPRAGMA INSTANCE inst_type END_UPRAGMA
{
- $$ = mkispec_uprag($3, $4, startlineno);
+ $$ = mkispec_uprag($3, startlineno);
FN = NULL; SAMEFN = 0;
}
| qvars_list COMMA qvar { $$ = lapp($1,$3); }
;
-types_and_maybe_ids :
- type_and_maybe_id { $$ = lsing($1); }
- | types_and_maybe_ids COMMA type_and_maybe_id { $$ = lapp($1,$3); }
- ;
-
-type_and_maybe_id :
- tautype { $$ = mkvspec_ty_and_id($1,mknothing()); }
- | tautype EQUAL qvark { $$ = mkvspec_ty_and_id($1,mkjust($3)); }
-
/**********************************************************************
* *
polyatype : atype
;
-polytype : FORALL tyvars1 DOT
+polytype : FORALL var_list DOT
apptype DARROW tautype { $$ = mkforall($2, type2context($4), $6); }
- | FORALL tyvars1 DOT tautype { $$ = mkforall($2, Lnil, $4); }
+ | FORALL var_list DOT tautype { $$ = mkforall($2, Lnil, $4); }
| apptype DARROW tautype { $$ = mkimp_forall( type2context($1), $3); }
| tautype
;
+polytypes : polytype { $$ = lsing($1); }
+ | polytypes COMMA polytype { $$ = lapp($1,$3); }
+ ;
+
/* --------------------------- */
/* tautype is just a monomorphic type.
But it may have nested for-alls if we're in a rank-2 type */
| forall constr_after_context { $$ = mkconstrex ( $1, Lnil, $2 ); }
;
-forall : { $$ = Lnil }
- | FORALL tyvars1 DOT { $$ = $2; }
- ;
-
constr_context
: conapptype conargatype { $$ = type2context( mktapp($1,$2) ); }
| conargatype { $$ = type2context( $1 ); }
dorest { $$ = mkdoe($3,$<ulong>2); }
/* CCALL/CASM Expression */
- | CCALL ccallid cexps { $$ = mkccall($2,install_literal("n"),$3); }
- | CCALL ccallid { $$ = mkccall($2,install_literal("n"),Lnil); }
- | CCALL_GC ccallid cexps { $$ = mkccall($2,install_literal("p"),$3); }
- | CCALL_GC ccallid { $$ = mkccall($2,install_literal("p"),Lnil); }
- | CASM CLITLIT cexps { $$ = mkccall($2,install_literal("N"),$3); }
- | CASM CLITLIT { $$ = mkccall($2,install_literal("N"),Lnil); }
- | CASM_GC CLITLIT cexps { $$ = mkccall($2,install_literal("P"),$3); }
- | CASM_GC CLITLIT { $$ = mkccall($2,install_literal("P"),Lnil); }
+ | CCALL ccallid aexps { $$ = mkccall($2,install_literal("n"),$3); }
+ | CCALL_GC ccallid aexps { $$ = mkccall($2,install_literal("p"),$3); }
+ | CASM CLITLIT aexps { $$ = mkccall($2,install_literal("N"),$3); }
+ | CASM_GC CLITLIT aexps { $$ = mkccall($2,install_literal("P"),$3); }
/* SCC Expression */
| SCC STRING exp
;
/* ccall arguments */
-cexps : cexps aexp { $$ = lapp($1,$2); }
- | aexp { $$ = lsing($1); }
+aexps : aexps aexp { $$ = lapp($1,$2); }
+ | /* empty */ { $$ = Lnil; }
;
caserest: ocurly alts ccurly { $$ = $2; }
;
/* ---------------------------------------------- */
-tyvar : varid_noforall { $$ = $1; }
+tyvar : varid_noforall { $$ = $1; }
;
-/* tyvars1: At least one tyvar */
-tyvars1 : tyvar { $$ = lsing($1); }
- | tyvar tyvars1 { $$ = mklcons($1,$2); }
- ;
+/* var_list: At least one var; used mainly for tyvars */
+var_list : varid_noforall { $$ = lsing($1); }
+ | varid_noforall var_list { $$ = mklcons($1,$2); }
+ ;
+
+forall : /* Empty */ { $$ = Lnil }
+ | FORALL var_list DOT { $$ = $2; }
+ ;
+
/**********************************************************************
* *
#include "tree.h"
#include "entidt.h"
#include "gdexp.h"
+#include "rulevar.h"
extern char *input_filename;
extern tree hspmain();
case ispec_uprag:
PUTTAGSTR("SS");
plineno(gispec_line(b));
- pqid(gispec_clas(b));
pttype(gispec_ty(b));
break;
case inline_uprag:
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_rulevar where
+
+#include "HsVersions.h"
+
+import UgenUtil
+
+import U_ttype
+import U_list
+import U_tree
+%}}
+
+type rulevar;
+ prulevar : < gpvar : stringId ; >; /* Variable without signature */
+
+ prulevarsig : < gpsigvar : stringId ; /* With signature */
+ gpsigsig : ttype ; >;
+end;
\begin{code}
module PrelInfo (
+ module ThinAir,
+ module MkId,
+
builtinNames, -- Names of things whose *unique* must be known, but
-- that is all. If something is in here, you know that
-- if it's used at all then it's Name will be just as
-- it is here, unique and all. Includes all the
- -- wired-in names.
-
- thinAirIdNames, -- Names of non-wired-in Ids that may be used out of
- setThinAirIds, -- thin air in any compilation. If they are not wired in
- thinAirModules, -- we must be sure to import them from some Prelude
- -- interface file even if they are not overtly
- -- mentioned. Subset of builtinNames.
- noRepIntegerIds,
- noRepStrIds,
derivingOccurrences, -- For a given class C, this tells what other
-- things are needed as a result of a
-- deriving(C) clause
- -- Here are the thin-air Ids themselves
- addr2IntegerId,
- packStringForCId, unpackCStringId, unpackCString2Id,
- unpackCStringAppendId, unpackCStringFoldrId,
- foldrId,
-
-- Random other things
main_NAME, ioTyCon_NAME,
deRefStablePtr_NAME, makeStablePtr_NAME,
#include "HsVersions.h"
+
-- friends:
+import ThinAir -- Re-export all these
+import MkId -- Ditto
+
import PrelMods -- Prelude module names
-import PrelVals -- VALUES
-import MkId ( mkPrimitiveId )
-import PrimOp ( PrimOp(..), allThePrimOps )
+import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName )
import DataCon ( DataCon )
import PrimRep ( PrimRep(..) )
import TysPrim -- TYPES
import Var ( varUnique, Id )
import Name ( Name, OccName, Provenance(..),
NameSpace, tcName, clsName, varName, dataName,
+ mkKnownKeyGlobal,
getName, mkGlobalName, nameRdrName, systemProvenance
)
import RdrName ( rdrNameModule, rdrNameOcc, mkSrcQual )
import Type ( funTyCon )
import Bag
import Unique -- *Key stuff
-import UniqFM ( UniqFM, listToUFM, lookupWithDefaultUFM )
+import UniqFM ( UniqFM, listToUFM )
import Util ( isIn )
import Panic ( panic )
-
-import IOExts
\end{code}
%************************************************************************
unionManyBags (map getTyConNames wired_in_tycons)
-- Wired in Ids
- , listToBag (map getName wired_in_ids)
+ , listToBag (map getName wiredInIds)
-- PrimOps
, listToBag (map (getName . mkPrimitiveId) allThePrimOps)
%************************************************************************
%* *
-\subsection{Wired in Ids}
-%* *
-%************************************************************************
-
-\begin{code}
-wired_in_ids
- = [ -- These error-y things are wired in because we don't yet have
- -- a way to express in an interface file that the result type variable
- -- is 'open'; that is can be unified with an unboxed type
- --
- -- [The interface file format now carry such information, but there's
- -- no way yet of expressing at the definition site for these error-reporting
- -- functions that they have an 'open' result type. -- sof 1/99]
- --
- aBSENT_ERROR_ID
- , eRROR_ID
- , iRREFUT_PAT_ERROR_ID
- , nON_EXHAUSTIVE_GUARDS_ERROR_ID
- , nO_METHOD_BINDING_ERROR_ID
- , pAR_ERROR_ID
- , pAT_ERROR_ID
- , rEC_CON_ERROR_ID
- , rEC_UPD_ERROR_ID
-
- -- These three can't be defined in Haskell
- , realWorldPrimId
- , unsafeCoerceId
- , getTagId
- ]
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Thin air entities}
-%* *
-%************************************************************************
-
-These are Ids that we need to reference in various parts of the
-system, and we'd like to pull them out of thin air rather than pass
-them around. We'd also like to have all the IdInfo available for each
-one: i.e. everything that gets pulled out of the interface file.
-
-The solution is to generate this map of global Ids after the
-typechecker, and assign it to a global variable. Any subsequent
-pass may refer to the map to pull Ids out. Any invalid
-(i.e. pre-typechecker) access to the map will result in a panic.
-
-\begin{code}
-thinAirIdNames
- = map mkKnownKeyGlobal
- [
- -- Needed for converting literals to Integers (used in tidyCoreExpr)
- (varQual pREL_BASE SLIT("addr2Integer"), addr2IntegerIdKey)
-
- -- String literals
- , (varQual pREL_PACK SLIT("packCString#"), packCStringIdKey)
- , (varQual pREL_PACK SLIT("unpackCString#"), unpackCStringIdKey)
- , (varQual pREL_PACK SLIT("unpackNBytes#"), unpackCString2IdKey)
- , (varQual pREL_PACK SLIT("unpackAppendCString#"), unpackCStringAppendIdKey)
- , (varQual pREL_PACK SLIT("unpackFoldrCString#"), unpackCStringFoldrIdKey)
-
- -- Folds; introduced by desugaring list comprehensions
- , (varQual pREL_BASE SLIT("foldr"), foldrIdKey)
- ]
-
-thinAirModules = [pREL_PACK] -- See notes with RnIfaces.findAndReadIface
-
-noRepIntegerIds = [addr2IntegerId]
-
-noRepStrIds = [unpackCString2Id, unpackCStringId]
-
-addr2IntegerId = lookupThinAirId addr2IntegerIdKey
-
-packStringForCId = lookupThinAirId packCStringIdKey
-unpackCStringId = lookupThinAirId unpackCStringIdKey
-unpackCString2Id = lookupThinAirId unpackCString2IdKey
-unpackCStringAppendId = lookupThinAirId unpackCStringAppendIdKey
-unpackCStringFoldrId = lookupThinAirId unpackCStringFoldrIdKey
-
-foldrId = lookupThinAirId foldrIdKey
-\end{code}
-
-
-\begin{code}
-\end{code}
-
-\begin{code}
-thinAirIdMapRef :: IORef (UniqFM Id)
-thinAirIdMapRef = unsafePerformIO (newIORef (panic "thinAirIdMap: still empty"))
-
-setThinAirIds :: [Id] -> IO ()
-setThinAirIds thin_air_ids
- = writeIORef thinAirIdMapRef the_map
- where
- the_map = listToUFM [(varUnique id, id) | id <- thin_air_ids]
-
-thinAirIdMap :: UniqFM Id
-thinAirIdMap = unsafePerformIO (readIORef thinAirIdMapRef)
- -- Read it just once, the first time someone tugs on thinAirIdMap
-
-lookupThinAirId :: Unique -> Id
-lookupThinAirId uniq = lookupWithDefaultUFM thinAirIdMap
- (panic "lookupThinAirId: no mapping") uniq
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Built-in keys}
%* *
%************************************************************************
Ids, Synonyms, Classes and ClassOps with builtin keys.
\begin{code}
-mkKnownKeyGlobal :: (RdrName, Unique) -> Name
-mkKnownKeyGlobal (rdr_name, uniq)
- = mkGlobalName uniq (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
- systemProvenance
-
ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, ioTyConKey)
main_NAME = mkKnownKeyGlobal (main_RDR, mainKey)
, (concat_RDR, concatIdKey)
, (filter_RDR, filterIdKey)
, (zip_RDR, zipIdKey)
+ , (build_RDR, buildIdKey)
+ , (augment_RDR, augmentIdKey)
-- FFI primitive types that are not wired-in.
, (int8TyCon_RDR, int8TyConKey)
-- Others
, (otherwiseId_RDR, otherwiseIdKey)
, (assert_RDR, assertIdKey)
+ , (runSTRep_RDR, runSTRepIdKey)
]
\end{code}
to write them all down in one place.
\begin{code}
-prelude_primop op = nameRdrName (getName (mkPrimitiveId op))
-
-main_RDR = varQual mAIN SLIT("main")
-otherwiseId_RDR = varQual pREL_BASE SLIT("otherwise")
+main_RDR = varQual mAIN_Name SLIT("main")
+otherwiseId_RDR = varQual pREL_BASE_Name SLIT("otherwise")
intTyCon_RDR = nameRdrName (getName intTyCon)
-ioTyCon_RDR = tcQual pREL_IO_BASE SLIT("IO")
-ioDataCon_RDR = dataQual pREL_IO_BASE SLIT("IO")
-bindIO_RDR = varQual pREL_IO_BASE SLIT("bindIO")
-
-orderingTyCon_RDR = tcQual pREL_BASE SLIT("Ordering")
-rationalTyCon_RDR = tcQual pREL_NUM SLIT("Rational")
-ratioTyCon_RDR = tcQual pREL_NUM SLIT("Ratio")
-ratioDataCon_RDR = dataQual pREL_NUM SLIT(":%")
-
-byteArrayTyCon_RDR = tcQual pREL_ARR SLIT("ByteArray")
-mutableByteArrayTyCon_RDR = tcQual pREL_ARR SLIT("MutableByteArray")
-
-foreignObjTyCon_RDR = tcQual pREL_IO_BASE SLIT("ForeignObj")
-stablePtrTyCon_RDR = tcQual pREL_STABLE SLIT("StablePtr")
-stablePtrDataCon_RDR = dataQual pREL_STABLE SLIT("StablePtr")
-deRefStablePtr_RDR = varQual pREL_STABLE SLIT("deRefStablePtr")
-makeStablePtr_RDR = varQual pREL_STABLE SLIT("makeStablePtr")
-
-eqClass_RDR = clsQual pREL_BASE SLIT("Eq")
-ordClass_RDR = clsQual pREL_BASE SLIT("Ord")
-boundedClass_RDR = clsQual pREL_BASE SLIT("Bounded")
-numClass_RDR = clsQual pREL_BASE SLIT("Num")
-enumClass_RDR = clsQual pREL_BASE SLIT("Enum")
-monadClass_RDR = clsQual pREL_BASE SLIT("Monad")
-monadPlusClass_RDR = clsQual pREL_BASE SLIT("MonadPlus")
-functorClass_RDR = clsQual pREL_BASE SLIT("Functor")
-showClass_RDR = clsQual pREL_BASE SLIT("Show")
-realClass_RDR = clsQual pREL_NUM SLIT("Real")
-integralClass_RDR = clsQual pREL_NUM SLIT("Integral")
-fractionalClass_RDR = clsQual pREL_NUM SLIT("Fractional")
-floatingClass_RDR = clsQual pREL_NUM SLIT("Floating")
-realFracClass_RDR = clsQual pREL_NUM SLIT("RealFrac")
-realFloatClass_RDR = clsQual pREL_NUM SLIT("RealFloat")
-readClass_RDR = clsQual pREL_READ SLIT("Read")
-ixClass_RDR = clsQual iX SLIT("Ix")
-ccallableClass_RDR = clsQual pREL_GHC SLIT("CCallable")
-creturnableClass_RDR = clsQual pREL_GHC SLIT("CReturnable")
-
-fromInt_RDR = varQual pREL_BASE SLIT("fromInt")
-fromInteger_RDR = varQual pREL_BASE SLIT("fromInteger")
-minus_RDR = varQual pREL_BASE SLIT("-")
-succ_RDR = varQual pREL_BASE SLIT("succ")
-pred_RDR = varQual pREL_BASE SLIT("pred")
-toEnum_RDR = varQual pREL_BASE SLIT("toEnum")
-fromEnum_RDR = varQual pREL_BASE SLIT("fromEnum")
-enumFrom_RDR = varQual pREL_BASE SLIT("enumFrom")
-enumFromTo_RDR = varQual pREL_BASE SLIT("enumFromTo")
-enumFromThen_RDR = varQual pREL_BASE SLIT("enumFromThen")
-enumFromThenTo_RDR = varQual pREL_BASE SLIT("enumFromThenTo")
-
-thenM_RDR = varQual pREL_BASE SLIT(">>=")
-returnM_RDR = varQual pREL_BASE SLIT("return")
-failM_RDR = varQual pREL_BASE SLIT("fail")
-
-fromRational_RDR = varQual pREL_NUM SLIT("fromRational")
-negate_RDR = varQual pREL_BASE SLIT("negate")
-eq_RDR = varQual pREL_BASE SLIT("==")
-ne_RDR = varQual pREL_BASE SLIT("/=")
-le_RDR = varQual pREL_BASE SLIT("<=")
-lt_RDR = varQual pREL_BASE SLIT("<")
-ge_RDR = varQual pREL_BASE SLIT(">=")
-gt_RDR = varQual pREL_BASE SLIT(">")
-ltTag_RDR = dataQual pREL_BASE SLIT("LT")
-eqTag_RDR = dataQual pREL_BASE SLIT("EQ")
-gtTag_RDR = dataQual pREL_BASE SLIT("GT")
-max_RDR = varQual pREL_BASE SLIT("max")
-min_RDR = varQual pREL_BASE SLIT("min")
-compare_RDR = varQual pREL_BASE SLIT("compare")
-minBound_RDR = varQual pREL_BASE SLIT("minBound")
-maxBound_RDR = varQual pREL_BASE SLIT("maxBound")
-false_RDR = dataQual pREL_BASE SLIT("False")
-true_RDR = dataQual pREL_BASE SLIT("True")
-and_RDR = varQual pREL_BASE SLIT("&&")
-not_RDR = varQual pREL_BASE SLIT("not")
-compose_RDR = varQual pREL_BASE SLIT(".")
-append_RDR = varQual pREL_BASE SLIT("++")
-map_RDR = varQual pREL_BASE SLIT("map")
-concat_RDR = varQual mONAD SLIT("concat")
-filter_RDR = varQual mONAD SLIT("filter")
-zip_RDR = varQual pREL_LIST SLIT("zip")
-
-showList___RDR = varQual pREL_BASE SLIT("showList__")
-showsPrec_RDR = varQual pREL_BASE SLIT("showsPrec")
-showList_RDR = varQual pREL_BASE SLIT("showList")
-showSpace_RDR = varQual pREL_BASE SLIT("showSpace")
-showString_RDR = varQual pREL_BASE SLIT("showString")
-showParen_RDR = varQual pREL_BASE SLIT("showParen")
-
-range_RDR = varQual iX SLIT("range")
-index_RDR = varQual iX SLIT("index")
-inRange_RDR = varQual iX SLIT("inRange")
-
-readsPrec_RDR = varQual pREL_READ SLIT("readsPrec")
-readList_RDR = varQual pREL_READ SLIT("readList")
-readParen_RDR = varQual pREL_READ SLIT("readParen")
-lex_RDR = varQual pREL_READ SLIT("lex")
-readList___RDR = varQual pREL_READ SLIT("readList__")
-
-plus_RDR = varQual pREL_BASE SLIT("+")
-times_RDR = varQual pREL_BASE SLIT("*")
-mkInt_RDR = dataQual pREL_BASE SLIT("I#")
-
-int8TyCon_RDR = tcQual iNT SLIT("Int8")
-int16TyCon_RDR = tcQual iNT SLIT("Int16")
-int32TyCon_RDR = tcQual iNT SLIT("Int32")
-int64TyCon_RDR = tcQual pREL_ADDR SLIT("Int64")
-
-word8TyCon_RDR = tcQual wORD SLIT("Word8")
-word16TyCon_RDR = tcQual wORD SLIT("Word16")
-word32TyCon_RDR = tcQual wORD SLIT("Word32")
-word64TyCon_RDR = tcQual pREL_ADDR SLIT("Word64")
-
-error_RDR = varQual pREL_ERR SLIT("error")
-assert_RDR = varQual pREL_GHC SLIT("assert")
-assertErr_RDR = varQual pREL_ERR SLIT("assertError")
-
-eqH_Char_RDR = prelude_primop CharEqOp
-ltH_Char_RDR = prelude_primop CharLtOp
-eqH_Word_RDR = prelude_primop WordEqOp
-ltH_Word_RDR = prelude_primop WordLtOp
-eqH_Addr_RDR = prelude_primop AddrEqOp
-ltH_Addr_RDR = prelude_primop AddrLtOp
-eqH_Float_RDR = prelude_primop FloatEqOp
-ltH_Float_RDR = prelude_primop FloatLtOp
-eqH_Double_RDR = prelude_primop DoubleEqOp
-ltH_Double_RDR = prelude_primop DoubleLtOp
-eqH_Int_RDR = prelude_primop IntEqOp
-ltH_Int_RDR = prelude_primop IntLtOp
-geH_RDR = prelude_primop IntGeOp
-leH_RDR = prelude_primop IntLeOp
-minusH_RDR = prelude_primop IntSubOp
-tagToEnumH_RDR = prelude_primop TagToEnumOp
-
-getTag_RDR = varQual pREL_GHC SLIT("getTag#")
+ioTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("IO")
+ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO")
+bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO")
+
+orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering")
+rationalTyCon_RDR = tcQual pREL_NUM_Name SLIT("Rational")
+ratioTyCon_RDR = tcQual pREL_NUM_Name SLIT("Ratio")
+ratioDataCon_RDR = dataQual pREL_NUM_Name SLIT(":%")
+
+byteArrayTyCon_RDR = tcQual pREL_ARR_Name SLIT("ByteArray")
+mutableByteArrayTyCon_RDR = tcQual pREL_ARR_Name SLIT("MutableByteArray")
+
+foreignObjTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("ForeignObj")
+stablePtrTyCon_RDR = tcQual pREL_STABLE_Name SLIT("StablePtr")
+stablePtrDataCon_RDR = dataQual pREL_STABLE_Name SLIT("StablePtr")
+deRefStablePtr_RDR = varQual pREL_STABLE_Name SLIT("deRefStablePtr")
+makeStablePtr_RDR = varQual pREL_STABLE_Name SLIT("makeStablePtr")
+
+-- Random PrelBase data constructors
+mkInt_RDR = dataQual pREL_BASE_Name SLIT("I#")
+false_RDR = dataQual pREL_BASE_Name SLIT("False")
+true_RDR = dataQual pREL_BASE_Name SLIT("True")
+
+-- Random PrelBase functions
+and_RDR = varQual pREL_BASE_Name SLIT("&&")
+not_RDR = varQual pREL_BASE_Name SLIT("not")
+compose_RDR = varQual pREL_BASE_Name SLIT(".")
+append_RDR = varQual pREL_BASE_Name SLIT("++")
+map_RDR = varQual pREL_BASE_Name SLIT("map")
+build_RDR = varQual pREL_BASE_Name SLIT("build")
+augment_RDR = varQual pREL_BASE_Name SLIT("augment")
+
+-- Classes Eq and Ord
+eqClass_RDR = clsQual pREL_BASE_Name SLIT("Eq")
+ordClass_RDR = clsQual pREL_BASE_Name SLIT("Ord")
+eq_RDR = varQual pREL_BASE_Name SLIT("==")
+ne_RDR = varQual pREL_BASE_Name SLIT("/=")
+le_RDR = varQual pREL_BASE_Name SLIT("<=")
+lt_RDR = varQual pREL_BASE_Name SLIT("<")
+ge_RDR = varQual pREL_BASE_Name SLIT(">=")
+gt_RDR = varQual pREL_BASE_Name SLIT(">")
+ltTag_RDR = dataQual pREL_BASE_Name SLIT("LT")
+eqTag_RDR = dataQual pREL_BASE_Name SLIT("EQ")
+gtTag_RDR = dataQual pREL_BASE_Name SLIT("GT")
+max_RDR = varQual pREL_BASE_Name SLIT("max")
+min_RDR = varQual pREL_BASE_Name SLIT("min")
+compare_RDR = varQual pREL_BASE_Name SLIT("compare")
+
+-- Class Monad
+monadClass_RDR = clsQual pREL_BASE_Name SLIT("Monad")
+monadPlusClass_RDR = clsQual pREL_BASE_Name SLIT("MonadPlus")
+thenM_RDR = varQual pREL_BASE_Name SLIT(">>=")
+returnM_RDR = varQual pREL_BASE_Name SLIT("return")
+failM_RDR = varQual pREL_BASE_Name SLIT("fail")
+
+-- Class Functor
+functorClass_RDR = clsQual pREL_BASE_Name SLIT("Functor")
+
+-- Class Show
+showClass_RDR = clsQual pREL_SHOW_Name SLIT("Show")
+showList___RDR = varQual pREL_SHOW_Name SLIT("showList__")
+showsPrec_RDR = varQual pREL_SHOW_Name SLIT("showsPrec")
+showList_RDR = varQual pREL_SHOW_Name SLIT("showList")
+showSpace_RDR = varQual pREL_SHOW_Name SLIT("showSpace")
+showString_RDR = varQual pREL_SHOW_Name SLIT("showString")
+showParen_RDR = varQual pREL_SHOW_Name SLIT("showParen")
+
+
+-- Class Read
+readClass_RDR = clsQual pREL_READ_Name SLIT("Read")
+readsPrec_RDR = varQual pREL_READ_Name SLIT("readsPrec")
+readList_RDR = varQual pREL_READ_Name SLIT("readList")
+readParen_RDR = varQual pREL_READ_Name SLIT("readParen")
+lex_RDR = varQual pREL_READ_Name SLIT("lex")
+readList___RDR = varQual pREL_READ_Name SLIT("readList__")
+
+
+-- Class Num
+numClass_RDR = clsQual pREL_NUM_Name SLIT("Num")
+fromInt_RDR = varQual pREL_NUM_Name SLIT("fromInt")
+fromInteger_RDR = varQual pREL_NUM_Name SLIT("fromInteger")
+minus_RDR = varQual pREL_NUM_Name SLIT("-")
+negate_RDR = varQual pREL_NUM_Name SLIT("negate")
+plus_RDR = varQual pREL_NUM_Name SLIT("+")
+times_RDR = varQual pREL_NUM_Name SLIT("*")
+
+-- Other numberic classes
+realClass_RDR = clsQual pREL_NUM_Name SLIT("Real")
+integralClass_RDR = clsQual pREL_NUM_Name SLIT("Integral")
+fractionalClass_RDR = clsQual pREL_NUM_Name SLIT("Fractional")
+floatingClass_RDR = clsQual pREL_NUM_Name SLIT("Floating")
+realFracClass_RDR = clsQual pREL_NUM_Name SLIT("RealFrac")
+realFloatClass_RDR = clsQual pREL_NUM_Name SLIT("RealFloat")
+fromRational_RDR = varQual pREL_NUM_Name SLIT("fromRational")
+
+-- Class Ix
+ixClass_RDR = clsQual iX_Name SLIT("Ix")
+range_RDR = varQual iX_Name SLIT("range")
+index_RDR = varQual iX_Name SLIT("index")
+inRange_RDR = varQual iX_Name SLIT("inRange")
+
+-- Class CCallable and CReturnable
+ccallableClass_RDR = clsQual pREL_GHC_Name SLIT("CCallable")
+creturnableClass_RDR = clsQual pREL_GHC_Name SLIT("CReturnable")
+
+-- Class Enum
+enumClass_RDR = clsQual pREL_ENUM_Name SLIT("Enum")
+succ_RDR = varQual pREL_ENUM_Name SLIT("succ")
+pred_RDR = varQual pREL_ENUM_Name SLIT("pred")
+toEnum_RDR = varQual pREL_ENUM_Name SLIT("toEnum")
+fromEnum_RDR = varQual pREL_ENUM_Name SLIT("fromEnum")
+enumFrom_RDR = varQual pREL_ENUM_Name SLIT("enumFrom")
+enumFromTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromTo")
+enumFromThen_RDR = varQual pREL_ENUM_Name SLIT("enumFromThen")
+enumFromThenTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromThenTo")
+
+-- Class Bounded
+boundedClass_RDR = clsQual pREL_ENUM_Name SLIT("Bounded")
+minBound_RDR = varQual pREL_ENUM_Name SLIT("minBound")
+maxBound_RDR = varQual pREL_ENUM_Name SLIT("maxBound")
+
+
+-- List functions
+concat_RDR = varQual pREL_LIST_Name SLIT("concat")
+filter_RDR = varQual pREL_LIST_Name SLIT("filter")
+zip_RDR = varQual pREL_LIST_Name SLIT("zip")
+
+int8TyCon_RDR = tcQual iNT_Name SLIT("Int8")
+int16TyCon_RDR = tcQual iNT_Name SLIT("Int16")
+int32TyCon_RDR = tcQual iNT_Name SLIT("Int32")
+int64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Int64")
+
+word8TyCon_RDR = tcQual wORD_Name SLIT("Word8")
+word16TyCon_RDR = tcQual wORD_Name SLIT("Word16")
+word32TyCon_RDR = tcQual wORD_Name SLIT("Word32")
+word64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Word64")
+
+error_RDR = varQual pREL_ERR_Name SLIT("error")
+assert_RDR = varQual pREL_GHC_Name SLIT("assert")
+assertErr_RDR = varQual pREL_ERR_Name SLIT("assertError")
+runSTRep_RDR = varQual pREL_ST_Name SLIT("runSTRep")
+
+eqH_Char_RDR = primOpRdrName CharEqOp
+ltH_Char_RDR = primOpRdrName CharLtOp
+eqH_Word_RDR = primOpRdrName WordEqOp
+ltH_Word_RDR = primOpRdrName WordLtOp
+eqH_Addr_RDR = primOpRdrName AddrEqOp
+ltH_Addr_RDR = primOpRdrName AddrLtOp
+eqH_Float_RDR = primOpRdrName FloatEqOp
+ltH_Float_RDR = primOpRdrName FloatLtOp
+eqH_Double_RDR = primOpRdrName DoubleEqOp
+ltH_Double_RDR = primOpRdrName DoubleLtOp
+eqH_Int_RDR = primOpRdrName IntEqOp
+ltH_Int_RDR = primOpRdrName IntLtOp
+geH_RDR = primOpRdrName IntGeOp
+leH_RDR = primOpRdrName IntLeOp
+minusH_RDR = primOpRdrName IntSubOp
+
+tagToEnumH_RDR = primOpRdrName TagToEnumOp
+getTag_RDR = varQual pREL_GHC_Name SLIT("getTag#")
\end{code}
\begin{code}
(
mkTupNameStr, mkUbxTupNameStr,
- pREL_GHC, pRELUDE, mONAD, rATIO, iX, mAIN, pREL_MAIN, pREL_ERR,
- pREL_BASE, pREL_NUM, pREL_LIST, pREL_TUP, pREL_ADDR, pREL_READ,
- pREL_PACK, pREL_CONC, pREL_IO_BASE, pREL_ST, pREL_ARR, pREL_FOREIGN,
- pREL_STABLE,
-
- iNT, wORD
+ pREL_GHC, pREL_BASE, pREL_ADDR, pREL_STABLE,
+ pREL_IO_BASE, pREL_PACK, pREL_ERR,
+
+ pREL_GHC_Name, pRELUDE_Name, mONAD_Name, rATIO_Name,
+ iX_Name, mAIN_Name, pREL_MAIN_Name, pREL_ERR_Name,
+ pREL_BASE_Name, pREL_NUM_Name, pREL_LIST_Name,
+ pREL_TUP_Name, pREL_ADDR_Name, pREL_READ_Name,
+ pREL_PACK_Name, pREL_CONC_Name, pREL_IO_BASE_Name,
+ pREL_ST_Name, pREL_ARR_Name, pREL_FOREIGN_Name,
+ pREL_STABLE_Name, pREL_SHOW_Name, pREL_ENUM_Name, iNT_Name, wORD_Name
) where
#include "HsVersions.h"
-import Module ( Module, mkPrelModule, mkSrcModule )
+import Module ( Module, ModuleName, mkPrelModule, mkSrcModule )
import Util ( nOfThem )
import Panic ( panic )
\end{code}
\begin{code}
-pREL_GHC, pRELUDE, mONAD, rATIO, iX, mAIN, pREL_MAIN, pREL_ERR :: Module
-pREL_BASE, pREL_NUM, pREL_LIST, pREL_TUP, pREL_ADDR, pREL_READ :: Module
-pREL_PACK, pREL_CONC, pREL_IO_BASE, pREL_ST, pREL_ARR :: Module
-pREL_FOREIGN, pREL_STABLE :: Module
-
-pRELUDE = mkPrelModule "Prelude"
-pREL_GHC = mkPrelModule "PrelGHC" -- Primitive types and values
-pREL_BASE = mkPrelModule "PrelBase"
-pREL_READ = mkPrelModule "PrelRead"
-pREL_NUM = mkPrelModule "PrelNum"
-pREL_LIST = mkPrelModule "PrelList"
-pREL_TUP = mkPrelModule "PrelTup"
-pREL_PACK = mkPrelModule "PrelPack"
-pREL_CONC = mkPrelModule "PrelConc"
-pREL_IO_BASE = mkPrelModule "PrelIOBase"
-pREL_ST = mkPrelModule "PrelST"
-pREL_ARR = mkPrelModule "PrelArr"
-pREL_FOREIGN = mkPrelModule "PrelForeign"
-pREL_STABLE = mkPrelModule "PrelStable"
-pREL_ADDR = mkPrelModule "PrelAddr"
-pREL_ERR = mkPrelModule "PrelErr"
-
-mONAD = mkPrelModule "Monad"
-rATIO = mkPrelModule "Ratio"
-iX = mkPrelModule "Ix"
-
-pREL_MAIN = mkPrelModule "PrelMain"
-mAIN = mkSrcModule "Main"
-
-iNT, wORD :: Module
-
-iNT = mkSrcModule "Int"
-wORD = mkSrcModule "Word"
-
+pRELUDE_Name = mkSrcModule "Prelude"
+pREL_GHC_Name = mkSrcModule "PrelGHC" -- Primitive types and values
+pREL_BASE_Name = mkSrcModule "PrelBase"
+pREL_ENUM_Name = mkSrcModule "PrelEnum"
+pREL_SHOW_Name = mkSrcModule "PrelShow"
+pREL_READ_Name = mkSrcModule "PrelRead"
+pREL_NUM_Name = mkSrcModule "PrelNum"
+pREL_LIST_Name = mkSrcModule "PrelList"
+pREL_TUP_Name = mkSrcModule "PrelTup"
+pREL_PACK_Name = mkSrcModule "PrelPack"
+pREL_CONC_Name = mkSrcModule "PrelConc"
+pREL_IO_BASE_Name = mkSrcModule "PrelIOBase"
+pREL_ST_Name = mkSrcModule "PrelST"
+pREL_ARR_Name = mkSrcModule "PrelArr"
+pREL_FOREIGN_Name = mkSrcModule "PrelForeign"
+pREL_STABLE_Name = mkSrcModule "PrelStable"
+pREL_ADDR_Name = mkSrcModule "PrelAddr"
+pREL_ERR_Name = mkSrcModule "PrelErr"
+
+mONAD_Name = mkSrcModule "Monad"
+rATIO_Name = mkSrcModule "Ratio"
+iX_Name = mkSrcModule "Ix"
+pREL_MAIN_Name = mkSrcModule "PrelMain"
+mAIN_Name = mkSrcModule "Main"
+iNT_Name = mkSrcModule "Int"
+wORD_Name = mkSrcModule "Word"
+
+pREL_GHC = mkPrelModule pREL_GHC_Name
+pREL_BASE = mkPrelModule pREL_BASE_Name
+pREL_ADDR = mkPrelModule pREL_ADDR_Name
+pREL_STABLE = mkPrelModule pREL_STABLE_Name
+pREL_IO_BASE = mkPrelModule pREL_IO_BASE_Name
+pREL_PACK = mkPrelModule pREL_PACK_Name
+pREL_ERR = mkPrelModule pREL_ERR_Name
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-mkTupNameStr, mkUbxTupNameStr :: Int -> (Module, FAST_STRING)
+mkTupNameStr, mkUbxTupNameStr :: Int -> (ModuleName, FAST_STRING)
-mkTupNameStr 0 = (pREL_BASE, SLIT("()"))
+mkTupNameStr 0 = (pREL_BASE_Name, SLIT("()"))
mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
-mkTupNameStr 2 = (pREL_TUP, _PK_ "(,)") -- not strictly necessary
-mkTupNameStr 3 = (pREL_TUP, _PK_ "(,,)") -- ditto
-mkTupNameStr 4 = (pREL_TUP, _PK_ "(,,,)") -- ditto
-mkTupNameStr n = (pREL_TUP, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")"))
+mkTupNameStr 2 = (pREL_TUP_Name, _PK_ "(,)") -- not strictly necessary
+mkTupNameStr 3 = (pREL_TUP_Name, _PK_ "(,,)") -- ditto
+mkTupNameStr 4 = (pREL_TUP_Name, _PK_ "(,,,)") -- ditto
+mkTupNameStr n = (pREL_TUP_Name, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")"))
mkUbxTupNameStr 0 = panic "Name.mkUbxTupNameStr: 0 ???"
-mkUbxTupNameStr 1 = (pREL_GHC, _PK_ "(# #)") -- 1 and 0 both make sense!!!
-mkUbxTupNameStr 2 = (pREL_GHC, _PK_ "(#,#)")
-mkUbxTupNameStr 3 = (pREL_GHC, _PK_ "(#,,#)")
-mkUbxTupNameStr 4 = (pREL_GHC, _PK_ "(#,,,#)")
-mkUbxTupNameStr n = (pREL_GHC, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)"))
+mkUbxTupNameStr 1 = (pREL_GHC_Name, _PK_ "(# #)") -- 1 and 0 both make sense!!!
+mkUbxTupNameStr 2 = (pREL_GHC_Name, _PK_ "(#,#)")
+mkUbxTupNameStr 3 = (pREL_GHC_Name, _PK_ "(#,,#)")
+mkUbxTupNameStr 4 = (pREL_GHC_Name, _PK_ "(#,,,#)")
+mkUbxTupNameStr n = (pREL_GHC_Name, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)"))
\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[PrelVals]{Prelude values the compiler ``knows about''}
-
-\begin{code}
-module PrelVals where
-
-#include "HsVersions.h"
-
-import {-# SOURCE #-} CoreUnfold ( mkUnfolding )
-
-import Id ( Id, mkVanillaId, setIdInfo, mkTemplateLocals )
-
--- friends:
-import PrelMods
-import TysPrim
-import TysWiredIn
-
--- others:
-import CoreSyn -- quite a bit
-import IdInfo -- quite a bit
-import PrimOp ( PrimOp(..) )
-import Const ( Con(..) )
-import Module ( Module )
-import Name ( mkWiredInIdName, mkSrcVarOcc )
-import Type
-import Var ( TyVar )
-import Demand ( wwStrict )
-import Unique -- lots of *Keys
-
-import IOExts
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Un-definable}
-%* *
-%************************************************************************
-
-These two can't be defined in Haskell.
-
-
-unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
-just gets expanded into a type coercion wherever it occurs. Hence we
-add it as a built-in Id with an unfolding here.
-
-The type variables we use here are "open" type variables: this means
-they can unify with both unlifted and lifted types. Hence we provide
-another gun with which to shoot yourself in the foot.
-
-\begin{code}
-unsafeCoerceId
- = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty
- (mk_inline_unfolding template)
- where
- (alphaTyVar:betaTyVar:_) = openAlphaTyVars
- alphaTy = mkTyVarTy alphaTyVar
- betaTy = mkTyVarTy betaTyVar
- ty = mkForAllTys [alphaTyVar,betaTyVar] (mkFunTy alphaTy betaTy)
- [x] = mkTemplateLocals [alphaTy]
- template = mkLams [alphaTyVar,betaTyVar,x] $
- Note (Coerce betaTy alphaTy) (Var x)
-\end{code}
-
-@getTag#@ is another function which can't be defined in Haskell. It needs to
-evaluate its argument and call the dataToTag# primitive.
-
-\begin{code}
-getTagId
- = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty
- (mk_inline_unfolding template)
- where
- ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy)
- [x,y] = mkTemplateLocals [alphaTy,alphaTy]
- template = mkLams [alphaTyVar,x] $
- Case (Var x) y [ (DEFAULT, [],
- Con (PrimOp DataToTagOp) [Type alphaTy, Var y]) ]
-\end{code}
-
-
-@realWorld#@ used to be a magic literal, \tr{void#}. If things get
-nasty as-is, change it back to a literal (@Literal@).
-
-\begin{code}
-realWorldPrimId
- = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
- realWorldStatePrimTy
- noCafIdInfo
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[PrelVals-error-related]{@error@ and friends; @trace@}
-%* *
-%************************************************************************
-
-GHC randomly injects these into the code.
-
-@patError@ is just a version of @error@ for pattern-matching
-failures. It knows various ``codes'' which expand to longer
-strings---this saves space!
-
-@absentErr@ is a thing we put in for ``absent'' arguments. They jolly
-well shouldn't be yanked on, but if one is, then you will get a
-friendly message from @absentErr@ (rather than a totally random
-crash).
-
-@parError@ is a special version of @error@ which the compiler does
-not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
-templates, but we don't ever expect to generate code for it.
-
-\begin{code}
-pc_bottoming_Id key mod name ty
- = pcMiscPrelId key mod name ty bottoming_info
- where
- bottoming_info = mkStrictnessInfo ([wwStrict], True) `setStrictnessInfo` noCafIdInfo
- -- these "bottom" out, no matter what their arguments
-
-eRROR_ID
- = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
-
-generic_ERROR_ID u n
- = pc_bottoming_Id u pREL_ERR n errorTy
-
-rEC_SEL_ERROR_ID
- = generic_ERROR_ID recSelErrIdKey SLIT("patError")
-pAT_ERROR_ID
- = generic_ERROR_ID patErrorIdKey SLIT("patError")
-rEC_CON_ERROR_ID
- = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
-rEC_UPD_ERROR_ID
- = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
-iRREFUT_PAT_ERROR_ID
- = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
-nON_EXHAUSTIVE_GUARDS_ERROR_ID
- = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
-nO_METHOD_BINDING_ERROR_ID
- = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
-
-aBSENT_ERROR_ID
- = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr")
- (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
-
-pAR_ERROR_ID
- = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
- (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafIdInfo
-
-openAlphaTy = mkTyVarTy openAlphaTyVar
-
-errorTy :: Type
-errorTy = mkUsgTy UsMany $
- mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkUsgTy UsOnce (mkListTy charTy)]
- (mkUsgTy UsMany openAlphaTy))
- -- Notice the openAlphaTyVar. It says that "error" can be applied
- -- to unboxed as well as boxed types. This is OK because it never
- -- returns, so the return type is irrelevant.
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Utilities}
-%* *
-%************************************************************************
-
-Note IMustBeINLINEd below. These things have the same status as
-constructor functions, i.e. they will *always* be inlined, wherever
-they occur.
-
-\begin{code}
-mk_inline_unfolding expr = setUnfoldingInfo (mkUnfolding expr) $
- setInlinePragInfo IMustBeINLINEd noIdInfo
-
-exactArityInfo n = exactArity n `setArityInfo` noIdInfo
-
-pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
-
-pcMiscPrelId key mod str ty info
- = let
- name = mkWiredInIdName key mod (mkSrcVarOcc str) imp
- imp = mkVanillaId name ty `setIdInfo` info -- the usual case...
- in
- imp
- -- We lie and say the thing is imported; otherwise, we get into
- -- a mess with dependency analysis; e.g., core2stg may heave in
- -- random calls to GHCbase.unpackPS__. If GHCbase is the module
- -- being compiled, then it's just a matter of luck if the definition
- -- will be in "the right place" to be in scope.
-
--- very useful...
-noCafIdInfo = NoCafRefs `setCafInfo` noIdInfo
-\end{code}
-
\begin{code}
module PrimOp (
PrimOp(..), allThePrimOps,
- tagOf_PrimOp, -- ToDo: rm
primOpType, primOpSig, primOpUsg,
- primOpUniq, primOpOcc,
+ mkPrimOpIdName, primOpRdrName,
commutableOp,
primOpOutOfLine, primOpNeedsWrapper, primOpStrictness,
- primOpOkForSpeculation, primOpIsCheap,
+ primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
primOpHasSideEffects,
getPrimOpResultInfo, PrimOpResultInfo(..),
import TysWiredIn
import Demand ( Demand, wwLazy, wwPrim, wwStrict )
-import Var ( TyVar )
+import Var ( TyVar, Id )
import CallConv ( CallConv, pprCallConv )
import PprType ( pprParendType )
+import Name ( Name, mkWiredInIdName )
+import RdrName ( RdrName, mkRdrQual )
import OccName ( OccName, pprOccName, mkSrcVarOcc )
import TyCon ( TyCon, tyConArity )
import Type ( Type, mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys,
UsageAnn(..), mkUsgTy
)
import Unique ( Unique, mkPrimOpIdUnique )
+import PrelMods ( pREL_GHC, pREL_GHC_Name )
import Outputable
import Util ( assoc, zipWithEqual )
import GlaExts ( Int(..), Int#, (==#) )
primOpIsCheap op = not (primOpHasSideEffects op || primOpOutOfLine op)
\end{code}
+primOpIsDupable means that the use of the primop is small enough to
+duplicate into different case branches. See CoreUtils.exprIsDupable.
+
+\begin{code}
+primOpIsDupable (CCallOp _ _ _ _) = False
+primOpIsDupable op = not (primOpOutOfLine op)
+\end{code}
+
+
\begin{code}
primOpCanFail :: PrimOp -> Bool
-- Int.
\end{code}
\begin{code}
-primOpOcc op
- = case (primOpInfo op) of
- Dyadic occ _ -> occ
- Monadic occ _ -> occ
- Compare occ _ -> occ
- GenPrimOp occ _ _ _ -> occ
-\end{code}
-
-\begin{code}
-primOpUniq :: PrimOp -> Unique
-primOpUniq op = mkPrimOpIdUnique (IBOX(tagOf_PrimOp op))
-
primOpType :: PrimOp -> Type -- you may want to use primOpSig instead
primOpType op
= case (primOpInfo op) of
GenPrimOp occ tyvars arg_tys res_ty ->
mkForAllTys tyvars (mkFunTys arg_tys res_ty)
+mkPrimOpIdName :: PrimOp -> Id -> Name
+ -- Make the name for the PrimOp's Id
+ -- We have to pass in the Id itself because it's a WiredInId
+ -- and hence recursive
+mkPrimOpIdName op id
+ = mkWiredInIdName key pREL_GHC occ_name id
+ where
+ occ_name = primOpOcc op
+ key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp op))
+
+
+primOpRdrName :: PrimOp -> RdrName
+primOpRdrName op = mkRdrQual pREL_GHC_Name (primOpOcc op)
+
+primOpOcc :: PrimOp -> OccName
+primOpOcc op = case (primOpInfo op) of
+ Dyadic occ _ -> occ
+ Monadic occ _ -> occ
+ Compare occ _ -> occ
+ GenPrimOp occ _ _ _ -> occ
+
-- primOpSig is like primOpType but gives the result split apart:
-- (type variables, argument types, result type)
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section{Thin air Ids}
+
+\begin{code}
+module ThinAir (
+ thinAirIdNames, -- Names of non-wired-in Ids that may be used out of
+ setThinAirIds, -- thin air in any compilation. If they are not wired in
+ thinAirModules, -- we must be sure to import them from some Prelude
+ -- interface file even if they are not overtly
+ -- mentioned. Subset of builtinNames.
+ -- Here are the thin-air Ids themselves
+ addr2IntegerId,
+ packStringForCId, unpackCStringId, unpackCString2Id,
+ unpackCStringAppendId, unpackCStringFoldrId,
+ foldrId, buildId,
+
+ noRepIntegerIds,
+ noRepStrIds
+
+ ) where
+
+#include "HsVersions.h"
+
+import Var ( Id, varUnique )
+import Name ( mkKnownKeyGlobal, varName )
+import RdrName ( mkPreludeQual )
+import PrelMods
+import UniqFM ( UniqFM, listToUFM, lookupWithDefaultUFM )
+import Unique
+import Outputable
+import IOExts
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Thin air entities}
+%* *
+%************************************************************************
+
+These are Ids that we need to reference in various parts of the
+system, and we'd like to pull them out of thin air rather than pass
+them around. We'd also like to have all the IdInfo available for each
+one: i.e. everything that gets pulled out of the interface file.
+
+The solution is to generate this map of global Ids after the
+typechecker, and assign it to a global variable. Any subsequent
+pass may refer to the map to pull Ids out. Any invalid
+(i.e. pre-typechecker) access to the map will result in a panic.
+
+\begin{code}
+thinAirIdNames
+ = map mkKnownKeyGlobal
+ [
+ -- Needed for converting literals to Integers (used in tidyCoreExpr)
+ (varQual pREL_BASE_Name SLIT("addr2Integer"), addr2IntegerIdKey)
+
+ -- String literals
+ , (varQual pREL_PACK_Name SLIT("packCString#"), packCStringIdKey)
+ , (varQual pREL_PACK_Name SLIT("unpackCString#"), unpackCStringIdKey)
+ , (varQual pREL_PACK_Name SLIT("unpackNBytes#"), unpackCString2IdKey)
+ , (varQual pREL_PACK_Name SLIT("unpackAppendCString#"), unpackCStringAppendIdKey)
+ , (varQual pREL_PACK_Name SLIT("unpackFoldrCString#"), unpackCStringFoldrIdKey)
+
+ -- Folds and builds; introduced by desugaring list comprehensions
+ , (varQual pREL_BASE_Name SLIT("foldr"), foldrIdKey)
+ , (varQual pREL_BASE_Name SLIT("build"), buildIdKey)
+ ]
+
+varQual = mkPreludeQual varName
+
+thinAirModules = [pREL_PACK_Name,pREL_BASE_Name] -- See notes with RnIfaces.findAndReadIface
+\end{code}
+
+
+\begin{code}
+noRepIntegerIds = [addr2IntegerId]
+
+noRepStrIds = [unpackCString2Id, unpackCStringId]
+
+addr2IntegerId = lookupThinAirId addr2IntegerIdKey
+
+packStringForCId = lookupThinAirId packCStringIdKey
+unpackCStringId = lookupThinAirId unpackCStringIdKey
+unpackCString2Id = lookupThinAirId unpackCString2IdKey
+unpackCStringAppendId = lookupThinAirId unpackCStringAppendIdKey
+unpackCStringFoldrId = lookupThinAirId unpackCStringFoldrIdKey
+
+foldrId = lookupThinAirId foldrIdKey
+buildId = lookupThinAirId buildIdKey
+\end{code}
+
+\begin{code}
+thinAirIdMapRef :: IORef (UniqFM Id)
+thinAirIdMapRef = unsafePerformIO (newIORef (panic "thinAirIdMap: still empty"))
+
+setThinAirIds :: [Id] -> IO ()
+setThinAirIds thin_air_ids
+ = writeIORef thinAirIdMapRef the_map
+ where
+ the_map = listToUFM [(varUnique id, id) | id <- thin_air_ids]
+
+thinAirIdMap :: UniqFM Id
+thinAirIdMap = unsafePerformIO (readIORef thinAirIdMapRef)
+ -- Read it just once, the first time someone tugs on thinAirIdMap
+
+lookupThinAirId :: Unique -> Id
+lookupThinAirId uniq = lookupWithDefaultUFM thinAirIdMap
+ (panic "lookupThinAirId: no mapping") uniq
+\end{code}
+
\begin{code}
realWorldTy = mkTyConTy realWorldTyCon
realWorldTyCon = pcPrimTyCon realWorldTyConKey SLIT("RealWorld") 0 [] PtrRep
-realWorldStatePrimTy = mkStatePrimTy realWorldTy
+realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld
\end{code}
Note: the ``state-pairing'' types are not truly primitive, so they are
-- others:
import Constants ( mAX_TUPLE_SIZE )
-import Module ( Module )
+import Module ( Module, mkPrelModule )
import Name ( mkWiredInTyConName, mkWiredInIdName, mkSrcOccFS, dataName )
-import DataCon ( DataCon, mkDataCon )
+import DataCon ( DataCon, StrictnessMark(..), mkDataCon )
import Var ( TyVar, tyVarKind )
import TyCon ( TyCon, ArgVrcs, mkAlgTyCon, mkSynTyCon, mkTupleTyCon )
-import BasicTypes ( Arity, NewOrData(..),
- RecFlag(..), StrictnessMark(..) )
+import BasicTypes ( Arity, NewOrData(..), RecFlag(..) )
import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys,
mkArrowKinds, boxedTypeKind, unboxedTypeKind,
mkFunTy, mkFunTys, isUnLiftedType,
mk_tuple arity = (tycon, tuple_con)
where
tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con True
- tc_name = mkWiredInTyConName tc_uniq mod_name name_str tycon
+ tc_name = mkWiredInTyConName tc_uniq mod name_str tycon
tc_kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind
- tuple_con = pcDataCon dc_uniq mod_name name_str tyvars [] tyvar_tys tycon
+ tuple_con = pcDataCon dc_uniq mod name_str tyvars [] tyvar_tys tycon
tyvars = take arity alphaTyVars
tyvar_tys = mkTyVarTys tyvars
(mod_name, name_str) = mkTupNameStr arity
tc_uniq = mkTupleTyConUnique arity
dc_uniq = mkTupleDataConUnique arity
+ mod = mkPrelModule mod_name
unitTyCon = tupleTyCon 0
pairTyCon = tupleTyCon 2
mk_unboxed_tuple arity = (tycon, tuple_con)
where
tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con False
- tc_name = mkWiredInTyConName tc_uniq mod_name name_str tycon
+ tc_name = mkWiredInTyConName tc_uniq mod name_str tycon
tc_kind = mkArrowKinds (map tyVarKind tyvars) unboxedTypeKind
- tuple_con = pcDataCon dc_uniq mod_name name_str tyvars [] tyvar_tys tycon
+ tuple_con = pcDataCon dc_uniq mod name_str tyvars [] tyvar_tys tycon
tyvars = take arity openAlphaTyVars
tyvar_tys = mkTyVarTys tyvars
(mod_name, name_str) = mkUbxTupNameStr arity
tc_uniq = mkUbxTupleTyConUnique arity
dc_uniq = mkUbxTupleDataConUnique arity
+ mod = mkPrelModule mod_name
unboxedPairTyCon = unboxedTupleTyCon 2
unboxedPairDataCon = unboxedTupleCon 2
import Name ( UserFS, EncodedFS, encodeFS, decode,
getOccName, occNameFS
)
-import Module ( Module, pprModule, moduleUserString )
+import Module ( Module, ModuleName, moduleName,
+ pprModuleName, moduleNameUserString
+ )
import Outputable
import Util ( thenCmp )
\end{code}
| NormalCC {
cc_name :: CcName, -- Name of the cost centre itself
- cc_mod :: Module, -- Name of module defining this CC.
+ cc_mod :: ModuleName, -- Name of module defining this CC.
cc_grp :: Group, -- "Group" that this CC is in.
cc_is_dupd :: IsDupdCC, -- see below
cc_is_caf :: IsCafCC -- see below
}
| AllCafsCC {
- cc_mod :: Module, -- Name of module defining this CC.
+ cc_mod :: ModuleName, -- Name of module defining this CC.
cc_grp :: Group -- "Group" that this CC is in
-- Again, one "big" CAF cc per module, where all
-- CAF costs are attributed unless the user asked for
\begin{code}
mkUserCC :: UserFS -> Module -> Group -> CostCentre
-mkUserCC cc_name module_name group_name
+mkUserCC cc_name mod group_name
= NormalCC { cc_name = encodeFS cc_name,
- cc_mod = module_name, cc_grp = group_name,
+ cc_mod = moduleName mod, cc_grp = group_name,
cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
}
mkAutoCC :: Id -> Module -> Group -> IsCafCC -> CostCentre
-mkAutoCC id module_name group_name is_caf
+mkAutoCC id mod group_name is_caf
= NormalCC { cc_name = occNameFS (getOccName id),
- cc_mod = module_name, cc_grp = group_name,
+ cc_mod = moduleName mod, cc_grp = group_name,
cc_is_dupd = OriginalCC, cc_is_caf = is_caf
}
-mkAllCafsCC m g = AllCafsCC { cc_mod = m, cc_grp = g }
+mkAllCafsCC m g = AllCafsCC { cc_mod = moduleName m, cc_grp = g }
mkSingletonCCS :: CostCentre -> CostCentreStack
mkSingletonCCS cc = SingletonCCS cc
| otherwise = True
ccFromThisModule :: CostCentre -> Module -> Bool
-ccFromThisModule cc m = cc_mod cc == m
+ccFromThisModule cc m = cc_mod cc == moduleName m
\end{code}
\begin{code}
-- Printing in an interface file or in Core generally
pprCostCentreCore (AllCafsCC {cc_mod = m, cc_grp = g})
- = text "__sccC" <+> braces (pprModule m <+> doubleQuotes (ptext g))
+ = text "__sccC" <+> braces (pprModuleName m <+> doubleQuotes (ptext g))
pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, cc_grp = g,
cc_is_caf = caf, cc_is_dupd = dup})
= text "__scc" <+> braces (hsep [
ptext n,
- pprModule m,
+ pprModuleName m,
doubleQuotes (ptext g),
pp_dup dup,
pp_caf caf
-- Printing as a C label
ppCostCentreLbl (NoCostCentre) = text "CC_NONE"
-ppCostCentreLbl (AllCafsCC {cc_mod = m}) = text "CC_CAFs_" <> pprModule m
+ppCostCentreLbl (AllCafsCC {cc_mod = m}) = text "CC_CAFs_" <> pprModuleName m
ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf})
= text "CC_" <> text (case is_caf of { CafCC -> "CAF_"; _ -> "" })
- <> pprModule m <> ptext n
+ <> pprModuleName m <> ptext n
-- This is the name to go in the user-displayed string,
-- recorded in the cost centre declaration
= if is_local then
hcat [
ptext SLIT("CC_DECLARE"),char '(',
- cc_ident, comma,
- doubleQuotes (text (costCentreUserName cc)), comma,
- doubleQuotes (text (moduleUserString mod_name)), comma,
- doubleQuotes (ptext grp_name), comma,
- ptext is_subsumed, comma,
+ cc_ident, comma,
+ doubleQuotes (text (costCentreUserName cc)), comma,
+ doubleQuotes (text (moduleNameUserString mod_name)), comma,
+ doubleQuotes (ptext grp_name), comma,
+ ptext is_subsumed, comma,
empty, -- Now always externally visible
text ");"]
else
import IdInfo ( InlinePragInfo(..), CprInfo(..) )
import Name ( isLowerISO, isUpperISO )
-import Module ( IfaceFlavour, hiFile, hiBootFile )
import PrelMods ( mkTupNameStr, mkUbxTupNameStr )
import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck )
import Demand ( Demand(..) {- instance Read -} )
| ITinterface -- GHC-extension keywords
| ITexport
- | ITinstimport
+ | ITdepends
| ITforall
| ITletrec
| ITcoerce
- | ITinline
+ | ITinlineCall
+ | ITinlineMe
| ITccall (Bool,Bool,Bool) -- (is_dyn, is_casm, may_gc)
| ITdefaultbranch
| ITbottom
| ITonce -- usage annotations
| ITmany
| ITarity
+ | ITrules
| ITspecialise
| ITnocaf
| ITunfold InlinePragInfo
| ITconid FAST_STRING
| ITvarsym FAST_STRING
| ITconsym FAST_STRING
- | ITqvarid (FAST_STRING,FAST_STRING,IfaceFlavour)
- | ITqconid (FAST_STRING,FAST_STRING,IfaceFlavour)
- | ITqvarsym (FAST_STRING,FAST_STRING,IfaceFlavour)
- | ITqconsym (FAST_STRING,FAST_STRING,IfaceFlavour)
+ | ITqvarid (FAST_STRING,FAST_STRING)
+ | ITqconid (FAST_STRING,FAST_STRING)
+ | ITqvarsym (FAST_STRING,FAST_STRING)
+ | ITqconsym (FAST_STRING,FAST_STRING)
| ITpragma StringBuffer
case expandWhile# is_ident buf of { buf1 ->
case expandWhile# (eqChar# '#'#) buf1 of { buf' ->
case currentChar# buf' of
- '.'# -> munch hiFile
- '!'# -> munch hiBootFile
+ '.'# -> lex_qid cont lexeme (stepOn new_buf) just_a_conid
_ -> just_a_conid
where
cont (ITconid lexeme) new_buf
lexeme = lexemeToFastString buf'
new_buf = stepOverLexeme buf'
- munch hif = lex_qid cont lexeme hif (stepOn new_buf) just_a_conid
}}
-lex_qid cont mod hif buf just_a_conid =
+lex_qid cont mod buf just_a_conid =
case currentChar# buf of
'['# -> -- Special case for []
case lookAhead# buf 1# of
- ']'# -> cont (ITqconid (mod,SLIT("[]"),hif)) (stepOnBy# buf 2#)
+ ']'# -> cont (ITqconid (mod,SLIT("[]"))) (stepOnBy# buf 2#)
_ -> just_a_conid
'('# -> -- Special case for (,,,)
-- This *is* necessary to deal with e.g. "instance C PrelBase.(,,)"
case lookAhead# buf 1# of
'#'# -> case lookAhead# buf 2# of
- ','# -> lex_ubx_tuple cont mod hif (stepOnBy# buf 3#)
+ ','# -> lex_ubx_tuple cont mod (stepOnBy# buf 3#)
just_a_conid
_ -> just_a_conid
- ')'# -> cont (ITqconid (mod,SLIT("()"),hif)) (stepOnBy# buf 2#)
- ','# -> lex_tuple cont mod hif (stepOnBy# buf 2#) just_a_conid
+ ')'# -> cont (ITqconid (mod,SLIT("()"))) (stepOnBy# buf 2#)
+ ','# -> lex_tuple cont mod (stepOnBy# buf 2#) just_a_conid
_ -> just_a_conid
'-'# -> case lookAhead# buf 1# of
- '>'# -> cont (ITqconid (mod,SLIT("->"),hif)) (stepOnBy# buf 2#)
- _ -> lex_id3 cont mod hif buf just_a_conid
- _ -> lex_id3 cont mod hif buf just_a_conid
+ '>'# -> cont (ITqconid (mod,SLIT("->"))) (stepOnBy# buf 2#)
+ _ -> lex_id3 cont mod buf just_a_conid
+ _ -> lex_id3 cont mod buf just_a_conid
-lex_id3 cont mod hif buf just_a_conid
+lex_id3 cont mod buf just_a_conid
| is_symbol c =
case expandWhile# is_symbol buf of { buf' ->
let
in
case lookupUFM haskellKeySymsFM lexeme of {
Just kwd_token -> just_a_conid; -- avoid M.:: etc.
- Nothing -> cont (mk_qvar_token mod hif lexeme) new_buf
+ Nothing -> cont (mk_qvar_token mod lexeme) new_buf
}}
| otherwise =
Nothing ->
case lookupUFM ifaceKeywordsFM lexeme of { -- only for iface files
Just kwd_token -> just_a_conid;
- Nothing -> cont (mk_qvar_token mod hif lexeme) new_buf
+ Nothing -> cont (mk_qvar_token mod lexeme) new_buf
}}}}
where c = currentChar# buf
(C# f) = _HEAD_ pk_str
tl = _TAIL_ pk_str
-mk_qvar_token m hif token =
+mk_qvar_token m token =
case mk_var_token token of
- ITconid n -> ITqconid (m,n,hif)
- ITvarid n -> ITqvarid (m,n,hif)
- ITconsym n -> ITqconsym (m,n,hif)
- ITvarsym n -> ITqvarsym (m,n,hif)
+ ITconid n -> ITqconid (m,n)
+ ITvarid n -> ITqvarid (m,n)
+ ITconsym n -> ITqconsym (m,n)
+ ITvarsym n -> ITqvarsym (m,n)
_ -> ITunknown (show token)
\end{code}
Horrible stuff for dealing with M.(,,,)
\begin{code}
-lex_tuple cont mod hif buf back_off =
+lex_tuple cont mod buf back_off =
go 2 buf
where
go n buf =
case currentChar# buf of
','# -> go (n+1) (stepOn buf)
- ')'# -> cont (ITqconid (mod, snd (mkTupNameStr n),hif)) (stepOn buf)
+ ')'# -> cont (ITqconid (mod, snd (mkTupNameStr n))) (stepOn buf)
_ -> back_off
-lex_ubx_tuple cont mod hif buf back_off =
+lex_ubx_tuple cont mod buf back_off =
go 2 buf
where
go n buf =
case currentChar# buf of
','# -> go (n+1) (stepOn buf)
'#'# -> case lookAhead# buf 1# of
- ')'# -> cont (ITqconid (mod, snd (mkUbxTupNameStr n), hif))
+ ')'# -> cont (ITqconid (mod, snd (mkUbxTupNameStr n)))
(stepOnBy# buf 2#)
_ -> back_off
_ -> back_off
map (\ (x,y) -> (_PK_ x,y))
[ ("__interface", ITinterface),
("__export", ITexport),
- ("__instimport", ITinstimport),
+ ("__depends", ITdepends),
("__forall", ITforall),
("__letrec", ITletrec),
("__coerce", ITcoerce),
- ("__inline", ITinline),
+ ("__inline_me", ITinlineMe),
+ ("__inline_call", ITinlineCall),
("__DEFAULT", ITdefaultbranch),
("__bot", ITbottom),
("__integer", ITinteger_lit),
("__addr", ITaddr_lit),
("__litlit", ITlit_lit),
("__string", ITstring_lit),
+ ("__R", ITrules),
("__a", ITtypeapp),
("__o", ITonce),
("__m", ITmany),
("__P", ITspecialise),
("__C", ITnocaf),
("__u", ITunfold NoInlinePragInfo),
- ("__U", ITunfold IWantToBeINLINEd),
- ("__UU", ITunfold IMustBeINLINEd),
- ("__Unot", ITunfold IMustNotBeINLINEd),
- ("__Ux", ITunfold IAmALoopBreaker),
("__ccall", ITccall (False, False, False)),
("__ccall_GC", ITccall (False, False, True)),
\begin{code}
data RdrBinding
- = RdrNullBind
+ = -- On input we use the Empty/And form rather than a list
+ RdrNullBind
| RdrAndBindings RdrBinding RdrBinding
- | RdrTyClDecl RdrNameTyClDecl
- | RdrValBinding RdrNameMonoBinds -- Pattern or function binding
- | RdrInstDecl RdrNameInstDecl
- | RdrDefaultDecl RdrNameDefaultDecl
- | RdrForeignDecl RdrNameForeignDecl
-
- -- signatures are mysterious; we can't
- -- tell if its a Sig or a ClassOpSig,
- -- so we just save the pieces:
+
+ -- Value bindings havn't been united with their
+ -- signatures yet
+ | RdrValBinding RdrNameMonoBinds
+
+ -- Signatures are mysterious; we can't
+ -- tell if its a Sig or a ClassOpSig,
+ -- so we just save the pieces:
| RdrSig RdrNameSig
+ -- The remainder all fit into the main HsDecl form
+ | RdrHsDecl RdrNameHsDecl
+
type SigConverter = RdrNameSig -> RdrNameSig
\end{code}
where
go acc RdrNullBind = acc
go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
- go (topds, mbs, sigs) (RdrTyClDecl d) = (TyClD d : topds, mbs, sigs)
- go (topds, mbs, sigs) (RdrInstDecl d) = (InstD d : topds, mbs, sigs)
- go (topds, mbs, sigs) (RdrDefaultDecl d) = (DefD d : topds, mbs, sigs)
- go (topds, mbs, sigs) (RdrForeignDecl d) = (ForD d : topds, mbs, sigs)
+ go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs)
go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)
RdrNameSig,
RdrNameStmt,
RdrNameTyClDecl,
+ RdrNameRuleBndr,
+ RdrNameRuleDecl,
RdrNameClassOpPragmas,
RdrNameClassPragmas,
RdrNameDataPragmas,
RdrNameGenPragmas,
RdrNameInstancePragmas,
- extractHsTyVars, extractHsCtxtTyVars, extractPatsTyVars,
+ extractHsTyRdrNames,
+ extractPatsTyVars, extractRuleBndrsTyVars,
- mkOpApp, mkClassDecl
+ mkOpApp, mkClassDecl, mkClassOpSig
) where
#include "HsVersions.h"
import HsSyn
-import Name ( mkClassTyConOcc, mkClassDataConOcc )
+import OccName ( mkClassTyConOcc, mkClassDataConOcc,
+ mkSuperDictSelOcc, mkDefaultMethodOcc
+ )
import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc )
import Util ( thenCmp )
import HsPragmas ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas )
type RdrNameSig = Sig RdrName
type RdrNameStmt = Stmt RdrName RdrNamePat
type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
+type RdrNameRuleBndr = RuleBndr RdrName
+type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
type RdrNameClassOpPragmas = ClassOpPragmas RdrName
type RdrNameClassPragmas = ClassPragmas RdrName
%* *
%************************************************************************
-@extractHsTyVars@ looks just for things that could be type variables.
+@extractHsTyRdrNames@ finds the free variables of a HsType
It's used when making the for-alls explicit.
\begin{code}
-extractHsTyVars :: HsType RdrName -> [RdrName]
-extractHsTyVars ty = nub (extract_ty ty [])
+extractHsTyRdrNames :: HsType RdrName -> [RdrName]
+extractHsTyRdrNames ty = nub (extract_ty ty [])
-extractHsCtxtTyVars :: Context RdrName -> [RdrName]
-extractHsCtxtTyVars ty = nub (extract_ctxt ty [])
+extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
+extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
+ where
+ go (RuleBndr _) acc = acc
+ go (RuleBndrSig _ ty) acc = extract_ty ty acc
+
+extractHsCtxtRdrNames :: Context RdrName -> [RdrName]
+extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
extract_ctxt ctxt acc = foldr extract_ass acc ctxt
where
- extract_ass (cls, tys) acc = foldr extract_ty acc tys
+ extract_ass (cls, tys) acc = foldr extract_ty (cls : acc) tys
extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
extract_ty (MonoListTy ty) acc = extract_ty ty acc
extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys
extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoDictTy cls tys) acc = foldr extract_ty acc tys
+extract_ty (MonoDictTy cls tys) acc = foldr extract_ty (cls : acc) tys
extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc
-extract_ty (MonoTyVar tv) acc = insertTV tv acc
+extract_ty (MonoTyVar tv) acc = tv : acc
extract_ty (HsForAllTy (Just tvs) ctxt ty)
acc = acc ++
(filter (`notElem` locals) $
where
locals = map getTyVarName tvs
-insertTV name acc | isRdrTyVar name = name : acc
-insertTV other acc = acc
extractPatsTyVars :: [RdrNamePat] -> [RdrName]
extractPatsTyVars pats = nub (foldr extract_pat [] pats)
by deriving them from the name of the class. We fill in the names for the
tycon and datacon corresponding to the class, by deriving them from the
name of the class itself. This saves recording the names in the interface
-file (which would be equally godd).
+file (which would be equally good).
+
+Similarly for mkClassOpSig and default-method names.
\begin{code}
mkClassDecl cxt cname tyvars sigs mbinds prags loc
- = ClassDecl cxt cname tyvars sigs mbinds prags tname dname loc
+ = ClassDecl cxt cname tyvars sigs mbinds prags tname dname sc_sel_names loc
where
cls_occ = rdrNameOcc cname
dname = mkRdrUnqual (mkClassDataConOcc cls_occ)
tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
+ sc_sel_names = [mkRdrUnqual (mkSuperDictSelOcc n cls_occ) | n <- [1..length cxt]]
+ -- We number off the superclass selectors, 1, 2, 3 etc so that we can construct
+ -- names for the selectors. Thus
+ -- class (C a, C b) => D a b where ...
+ -- gives superclass selectors
+ -- D_sc1, D_sc2
+ -- (We used to call them D_C, but now we can have two different
+ -- superclasses both called C!)
+
+mkClassOpSig has_default_method op ty loc
+ | not has_default_method = ClassOpSig op Nothing ty loc
+ | otherwise = ClassOpSig op (Just dm_rn) ty loc
+ where
+ dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
\end{code}
-
-
import HsPragmas ( noDataPragmas, noClassPragmas )
import RdrHsSyn
import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) )
-import PrelMods ( pRELUDE )
+import PrelMods ( pRELUDE_Name )
import PrefixToHs
import CallConv
-import CmdLineOpts ( opt_NoImplicitPrelude, opt_GlasgowExts )
-import Module ( Module, mkSrcModuleFS, mkImportModuleFS,
- hiFile, hiBootFile
- )
+import CmdLineOpts ( opt_NoImplicitPrelude, opt_GlasgowExts, opt_D_dump_rdr )
+import Module ( ModuleName, mkSrcModuleFS, WhereFrom(..) )
import OccName ( NameSpace, tcName, clsName, tcClsName, varName, dataName, tvName,
isLexCon
)
dummyRdrVarName
)
import Outputable
+import ErrUtils ( dumpIfSet )
import SrcLoc ( SrcLoc )
import FastString ( mkFastCharString )
import PrelRead ( readRational__ )
%************************************************************************
%* *
-\subsection[ReadPrefix-help]{Help Functions}
+\subsection[rdModule]{@rdModule@: reads in a Haskell module}
%* *
%************************************************************************
\begin{code}
-wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
-
-wlkList wlk_it U_lnil = returnUgn []
-
-wlkList wlk_it (U_lcons hd tl)
- = wlk_it hd `thenUgn` \ hd_it ->
- wlkList wlk_it tl `thenUgn` \ tl_it ->
- returnUgn (hd_it : tl_it)
-\end{code}
-
-\begin{code}
-wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
-
-wlkMaybe wlk_it U_nothing = returnUgn Nothing
-wlkMaybe wlk_it (U_just x)
- = wlk_it x `thenUgn` \ it ->
- returnUgn (Just it)
-\end{code}
-
-\begin{code}
-wlkTcClsId = wlkQid (\_ -> tcClsName)
-wlkTcId = wlkQid (\_ -> tcName)
-wlkClsId = wlkQid (\_ -> clsName)
-wlkVarId = wlkQid (\occ -> if isLexCon occ
- then dataName
- else varName)
-wlkDataId = wlkQid (\_ -> dataName)
-wlkEntId = wlkQid (\occ -> if isLexCon occ
- then tcClsName
- else varName)
-
-wlkQid :: (FAST_STRING -> NameSpace) -> U_qid -> UgnM RdrName
-
--- There are three kinds of qid:
--- qualified name (aqual) A.x
--- unqualified name (noqual) x
--- special name (gid) [], (), ->, (,,,)
--- The special names always mean "Prelude.whatever"; that's why
--- they are distinct. So if you write "()", it's just as if you
--- had written "Prelude.()".
--- NB: The (qualified) prelude is always in scope, so the renamer will find it.
-
--- EXCEPT: when we're compiling with -fno-implicit-prelude, in which
--- case we need to unqualify these things. -- SDM.
-
-wlkQid mk_name_space (U_noqual name)
- = returnUgn (mkSrcUnqual (mk_name_space name) name)
-wlkQid mk_name_space (U_aqual mod name)
- = returnUgn (mkSrcQual (mk_name_space name) mod name)
-wlkQid mk_name_space (U_gid n name) -- Built in Prelude things
- | opt_NoImplicitPrelude
- = returnUgn (mkSrcUnqual (mk_name_space name) name)
- | otherwise
- = returnUgn (mkPreludeQual (mk_name_space name) pRELUDE name)
-
-
-rdTCId pt = rdU_qid pt `thenUgn` wlkTcId
-rdVarId pt = rdU_qid pt `thenUgn` wlkVarId
+rdModule :: IO (ModuleName, -- this module's name
+ RdrNameHsModule) -- the main goods
-rdTvId pt = rdU_stringId pt `thenUgn` \ string -> wlkTvId string
-wlkTvId string = returnUgn (mkSrcUnqual tvName string)
+rdModule
+ = -- call the Yacc parser!
+ _ccall_ hspmain >>= \ pt ->
-cvFlag :: U_long -> Bool
-cvFlag 0 = False
-cvFlag 1 = True
-\end{code}
+ -- Read from the Yacc tree
+ initUgn (read_module pt) >>= \ (mod_name, rdr_module) ->
-%************************************************************************
-%* *
-\subsection[rdModule]{@rdModule@: reads in a Haskell module}
-%* *
-%************************************************************************
+ -- Dump if reqd
+ dumpIfSet opt_D_dump_rdr "Reader"
+ (ppr rdr_module) >>
-\begin{code}
-rdModule :: IO (Module, -- this module's name
- RdrNameHsModule) -- the main goods
+ -- And return
+ return (mod_name, rdr_module)
-rdModule
- = _ccall_ hspmain >>= \ pt -> -- call the Yacc parser!
- let
- srcfile = mkFastCharString ``input_filename'' -- What A Great Hack! (TM)
- in
- initUgn $
- rdU_tree pt `thenUgn` \ (U_hmodule mod_fs himplist hexplist
+read_module :: ParseTree -> UgnM (ModuleName, RdrNameHsModule)
+read_module pt
+ = rdU_tree pt `thenUgn` \ (U_hmodule mod_fs himplist hexplist
hmodlist srciface_version srcline) ->
let
+ srcfile = mkFastCharString ``input_filename'' -- What A Great Hack! (TM)
mod_name = mkSrcModuleFS mod_fs
in
setSrcFileUgn srcfile $
- setSrcModUgn mod_name $
mkSrcLocUgn srcline $ \ src_loc ->
wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
wlkBinding hmodlist `thenUgn` \ binding ->
let
- top_decls = cvTopDecls srcfile binding
+ top_decls = cvTopDecls srcfile binding
+ rdr_module = HsModule mod_name
+ (case srciface_version of { 0 -> Nothing; n -> Just n })
+ exports
+ imports
+ top_decls
+ src_loc
in
- returnUgn (mod_name,
- HsModule mod_name
- (case srciface_version of { 0 -> Nothing; n -> Just n })
- exports
- imports
- top_decls
- src_loc
- )
+ returnUgn (mod_name, rdr_module)
\end{code}
%************************************************************************
wlkConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
wlkList rdConDecl tcons `thenUgn` \ cons ->
wlkDerivings tderivs `thenUgn` \ derivings ->
- returnUgn (RdrTyClDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
+ returnUgn (RdrHsDecl (TyClD (TyData DataType ctxt tycon tyvars cons
+ derivings noDataPragmas src_loc)))
-- "newtype" declaration
U_ntbind ntctxt nttype ntcon ntderivs srcline ->
wlkConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
wlkList rdConDecl ntcon `thenUgn` \ cons ->
wlkDerivings ntderivs `thenUgn` \ derivings ->
- returnUgn (RdrTyClDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
+ returnUgn (RdrHsDecl (TyClD (TyData NewType ctxt tycon tyvars cons
+ derivings noDataPragmas src_loc)))
-- "type" declaration
U_nbind nbindid nbindas srcline ->
mkSrcLocUgn srcline $ \ src_loc ->
wlkConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
wlkHsType nbindas `thenUgn` \ expansion ->
- returnUgn (RdrTyClDecl (TySynonym tycon tyvars expansion src_loc))
+ returnUgn (RdrHsDecl (TyClD (TySynonym tycon tyvars expansion src_loc)))
-- function binding
U_fbind fbindm srcline ->
let
(final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
in
- returnUgn (RdrTyClDecl
- (mkClassDecl ctxt clas tyvars final_sigs final_methods noClassPragmas src_loc))
+ returnUgn (RdrHsDecl (TyClD (mkClassDecl ctxt clas tyvars final_sigs
+ final_methods noClassPragmas src_loc)))
-- "instance" declaration
U_ibind ty ibindw srcline ->
mkSrcLocUgn srcline $ \ src_loc ->
wlkInstType ty `thenUgn` \ inst_ty ->
wlkBinding ibindw `thenUgn` \ binding ->
- getSrcModUgn `thenUgn` \ modname ->
getSrcFileUgn `thenUgn` \ sf ->
let
(binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
in
- returnUgn (RdrInstDecl
- (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
+ returnUgn (RdrHsDecl (InstD (InstDecl inst_ty binds uprags
+ dummyRdrVarName {- No dfun id yet -}
+ src_loc)))
-- "default" declaration
U_dbind dbindts srcline ->
mkSrcLocUgn srcline $ \ src_loc ->
wlkList rdMonoType dbindts `thenUgn` \ tys ->
- returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
+ returnUgn (RdrHsDecl (DefD (DefaultDecl tys src_loc)))
-- "foreign" declaration
U_fobind id ty ext_name unsafe_flag cconv imp_exp srcline ->
wlkExtName ext_name `thenUgn` \ h_ext_name ->
rdCallConv cconv `thenUgn` \ h_cconv ->
rdForKind imp_exp (cvFlag unsafe_flag) `thenUgn` \ h_imp_exp ->
- returnUgn (RdrForeignDecl (ForeignDecl h_id h_imp_exp h_ty h_ext_name h_cconv src_loc))
+ returnUgn (RdrHsDecl (ForD (ForeignDecl h_id h_imp_exp h_ty h_ext_name h_cconv src_loc)))
U_sbind sbindids sbindid srcline ->
-- Type signature
-- value specialisation user-pragma
mkSrcLocUgn srcline $ \ src_loc ->
wlkVarId uvar `thenUgn` \ var ->
- wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
- returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty using_id src_loc)
- | (ty, using_id) <- tys_and_ids ])
- where
- rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
- rd_ty_and_id pt
- = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
- wlkHsSigType vspec_ty `thenUgn` \ ty ->
- wlkMaybe rdVarId vspec_id `thenUgn` \ id_maybe ->
- returnUgn(ty, id_maybe)
-
- U_ispec_uprag iclas ispec_ty srcline ->
+ wlkList rdHsSigType vspec_tys `thenUgn` \ tys ->
+ returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty src_loc)
+ | ty <- tys ])
+
+ U_ispec_uprag ispec_ty srcline ->
-- instance specialisation user-pragma
mkSrcLocUgn srcline $ \ src_loc ->
- wlkHsSigType ispec_ty `thenUgn` \ ty ->
+ wlkInstType ispec_ty `thenUgn` \ ty ->
returnUgn (RdrSig (SpecInstSig ty src_loc))
U_inline_uprag ivar srcline ->
wlkVarId ivar `thenUgn` \ var ->
returnUgn (RdrSig (NoInlineSig var src_loc))
+ U_rule_prag name ivars ilhs irhs srcline ->
+ -- Transforamation rule
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkList rdRuleBndr ivars `thenUgn` \ vars ->
+ rdExpr ilhs `thenUgn` \ lhs ->
+ rdExpr irhs `thenUgn` \ rhs ->
+ returnUgn (RdrHsDecl (RuleD (RuleDecl name [] vars lhs rhs src_loc)))
mkRdrFunctionBinding :: [RdrNameMatch] -> SrcLoc -> RdrNameMonoBinds
mkRdrFunctionBinding fun_matches src_loc
de_fun_match (Match _ [ConOpPatIn p1 fn _ p2] sig grhss) = (fn, True, Match [] [p1,p2] sig grhss)
+rdRuleBndr :: ParseTree -> UgnM RdrNameRuleBndr
+rdRuleBndr pt = rdU_rulevar pt `thenUgn` wlkRuleBndr
+
+wlkRuleBndr :: U_rulevar -> UgnM RdrNameRuleBndr
+wlkRuleBndr (U_prulevar v)
+ = returnUgn (RuleBndr (mkSrcUnqual varName v))
+wlkRuleBndr (U_prulevarsig v ty)
+ = wlkHsType ty `thenUgn` \ ty' ->
+ returnUgn (RuleBndrSig (mkSrcUnqual varName v) ty')
+
+
+
rdGRHSs :: ParseTree -> UgnM RdrNameGRHSs
rdGRHSs pt = rdU_grhsb pt `thenUgn` wlkGRHSs
%************************************************************************
\begin{code}
-rdHsType :: ParseTree -> UgnM RdrNameHsType
-rdMonoType :: ParseTree -> UgnM RdrNameHsType
+rdHsSigType :: ParseTree -> UgnM RdrNameHsType
+rdHsType :: ParseTree -> UgnM RdrNameHsType
+rdMonoType :: ParseTree -> UgnM RdrNameHsType
-rdHsType pt = rdU_ttype pt `thenUgn` wlkHsType
-rdMonoType pt = rdU_ttype pt `thenUgn` wlkHsType
+rdHsSigType pt = rdU_ttype pt `thenUgn` wlkHsSigType
+rdHsType pt = rdU_ttype pt `thenUgn` wlkHsType
+rdMonoType pt = rdU_ttype pt `thenUgn` wlkHsType
wlkHsConstrArgType ttype
-- Used for the argument types of contructors
mkSrcLocUgn srcline $ \ src_loc ->
wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
- returnUgn (ImportDecl (mkImportModuleFS imod (cvIfaceFlavour isrc))
+ returnUgn (ImportDecl (mkSrcModuleFS imod)
+ (cvImportSource isrc)
(cvFlag iqual)
(case maybe_as of { Just m -> Just (mkSrcModuleFS m); Nothing -> Nothing })
maybe_spec src_loc)
U_right pt -> rdEntities pt `thenUgn` \ ents ->
returnUgn (True, ents)
-cvIfaceFlavour 0 = hiFile -- No pragam
-cvIfaceFlavour 1 = hiBootFile -- {-# SOURCE #-}
+cvImportSource 0 = ImportByUser -- No pragam
+cvImportSource 1 = ImportByUserSource -- {-# SOURCE #-}
\end{code}
\begin{code}
returnUgn FoLabel
\end{code}
+
+%************************************************************************
+%* *
+\subsection[ReadPrefix-help]{Help Functions}
+%* *
+%************************************************************************
+
+\begin{code}
+wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
+
+wlkList wlk_it U_lnil = returnUgn []
+
+wlkList wlk_it (U_lcons hd tl)
+ = wlk_it hd `thenUgn` \ hd_it ->
+ wlkList wlk_it tl `thenUgn` \ tl_it ->
+ returnUgn (hd_it : tl_it)
+\end{code}
+
+\begin{code}
+wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
+
+wlkMaybe wlk_it U_nothing = returnUgn Nothing
+wlkMaybe wlk_it (U_just x)
+ = wlk_it x `thenUgn` \ it ->
+ returnUgn (Just it)
+\end{code}
+
+\begin{code}
+wlkTcClsId = wlkQid (\_ -> tcClsName)
+wlkTcId = wlkQid (\_ -> tcName)
+wlkClsId = wlkQid (\_ -> clsName)
+wlkVarId = wlkQid (\occ -> if isLexCon occ
+ then dataName
+ else varName)
+wlkDataId = wlkQid (\_ -> dataName)
+wlkEntId = wlkQid (\occ -> if isLexCon occ
+ then tcClsName
+ else varName)
+
+wlkQid :: (FAST_STRING -> NameSpace) -> U_qid -> UgnM RdrName
+
+-- There are three kinds of qid:
+-- qualified name (aqual) A.x
+-- unqualified name (noqual) x
+-- special name (gid) [], (), ->, (,,,)
+-- The special names always mean "Prelude.whatever"; that's why
+-- they are distinct. So if you write "()", it's just as if you
+-- had written "Prelude.()".
+-- NB: The (qualified) prelude is always in scope, so the renamer will find it.
+
+-- EXCEPT: when we're compiling with -fno-implicit-prelude, in which
+-- case we need to unqualify these things. -- SDM.
+
+wlkQid mk_name_space (U_noqual name)
+ = returnUgn (mkSrcUnqual (mk_name_space name) name)
+wlkQid mk_name_space (U_aqual mod name)
+ = returnUgn (mkSrcQual (mk_name_space name) mod name)
+wlkQid mk_name_space (U_gid n name) -- Built in Prelude things
+ | opt_NoImplicitPrelude
+ = returnUgn (mkSrcUnqual (mk_name_space name) name)
+ | otherwise
+ = returnUgn (mkPreludeQual (mk_name_space name) pRELUDE_Name name)
+
+
+rdTCId pt = rdU_qid pt `thenUgn` wlkTcId
+rdVarId pt = rdU_qid pt `thenUgn` wlkVarId
+
+rdTvId pt = rdU_stringId pt `thenUgn` \ string -> wlkTvId string
+wlkTvId string = returnUgn (mkSrcUnqual tvName string)
+
+-- Unqualified variables, used in the 'forall' of a RULE
+rdUVarId pt = rdU_stringId pt `thenUgn` \ string -> wlkUVarId string
+wlkUVarId string = returnUgn (mkSrcUnqual varName string)
+
+cvFlag :: U_long -> Bool
+cvFlag 0 = False
+cvFlag 1 = True
+\end{code}
+
deadOccurrence, funOccurrence, noBinderInfo,
- markLazy, markMany, markInsideLam, markInsideSCC,
+ markMany, markInsideLam, markInsideSCC,
getBinderInfoArity,
setBinderInfoArityToZero,
deadOccurrence = DeadCode
funOccurrence :: Int -> BinderInfo
-funOccurrence = OneOcc StrictOcc NotInsideSCC 1
+funOccurrence = OneOcc NotInsideLam NotInsideSCC 1
-markLazy, markMany, markInsideLam, markInsideSCC :: BinderInfo -> BinderInfo
+markMany, markInsideLam, markInsideSCC :: BinderInfo -> BinderInfo
markMany (OneOcc _ _ _ ar) = ManyOcc ar
markMany (ManyOcc ar) = ManyOcc ar
markInsideSCC (OneOcc dup_danger _ n_alts ar) = OneOcc dup_danger InsideSCC n_alts ar
markInsideSCC other = other
-markLazy (OneOcc StrictOcc scc n_alts ar) = OneOcc LazyOcc scc n_alts ar
-markLazy other = other
-
addBinderInfo, orBinderInfo :: BinderInfo -> BinderInfo -> BinderInfo
addBinderInfo DeadCode info2 = info2
or_dups InsideLam _ = InsideLam
or_dups _ InsideLam = InsideLam
-or_dups StrictOcc StrictOcc = StrictOcc
-or_dups _ _ = LazyOcc
+or_dups _ _ = NotInsideLam
or_sccs InsideSCC _ = InsideSCC
or_sccs _ InsideSCC = InsideSCC
import CmdLineOpts ( opt_D_verbose_core2core )
import CoreSyn
import CoreLint ( beginPass, endPass )
-import FreeVars ( CoreExprWithFVs, freeVars, freeVarsOf )
-import Var ( Id )
+import Const ( isDataCon )
+import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf )
+import Var ( Id, idType )
+import Type ( isUnLiftedType )
import VarSet
import Util ( zipEqual )
import Outputable
-- the the call it annotates
mkCoLets' to_drop (Note InlineCall (fiExpr [] expr))
+fiExpr to_drop (_, AnnNote InlineMe expr)
+ = -- Ditto... don't float anything into an INLINE expression
+ mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
+
fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr)
= -- Just float in past coercion
Note note (fiExpr to_drop expr)
w = ...
in {
let v = ... w ...
- in ... w ...
+ in ... v .. w ...
}
\end{verbatim}
Look at the inner \tr{let}. As \tr{w} is used in both the bind and
body of the inner let, we could panic and leave \tr{w}'s binding where
-it is. But \tr{v} is floatable into the body of the inner let, and
+it is. But \tr{v} is floatable further into the body of the inner let, and
{\em then} \tr{w} will also be only in the body of that inner let.
So: rather than drop \tr{w}'s binding here, we add it onto the list of
course.
\begin{code}
-fiExpr to_drop (_,AnnLet (AnnNonRec id rhs) body)
+fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
= fiExpr new_to_drop body
where
- rhs_fvs = freeVarsOf rhs
body_fvs = freeVarsOf body
- [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint [rhs_fvs, body_fvs] to_drop
+ final_body_fvs | noFloatIntoRhs ann_rhs
+ || isUnLiftedType (idType id) = body_fvs `unionVarSet` rhs_fvs
+ | otherwise = body_fvs
+ -- See commments with letrec below
+ -- No point in floating in only to float straight out again
+ -- Ditto ok-for-speculation unlifted RHSs
+
+ [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint [rhs_fvs, final_body_fvs] to_drop
new_to_drop = body_binds ++ -- the bindings used only in the body
[(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself
rhss_fvs = map freeVarsOf rhss
body_fvs = freeVarsOf body
- (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop
+ -- Add to body_fvs the free vars of any RHS that has
+ -- a lambda at the top. This has the effect of making it seem
+ -- that such things are used in the body as well, and hence prevents
+ -- them getting floated in. The big idea is to avoid turning:
+ -- let x# = y# +# 1#
+ -- in
+ -- letrec f = \z. ...x#...f...
+ -- in ...
+ -- into
+ -- letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
+ --
+ -- Because now we can't float the let out again, because a letrec
+ -- can't have unboxed bindings.
+
+ final_body_fvs = foldr (unionVarSet . get_extras) body_fvs rhss
+ get_extras (rhs_fvs, rhs) | noFloatIntoRhs rhs = rhs_fvs
+ | otherwise = emptyVarSet
+
+ (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint (final_body_fvs:rhss_fvs) to_drop
new_to_drop = -- the bindings used only in the body
body_binds ++
-- to get free vars of alt
fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
+
+noFloatIntoRhs (AnnNote InlineMe _) = True
+noFloatIntoRhs (AnnLam _ _) = True
+noFloatIntoRhs (AnnCon con _) = isDataCon con
+noFloatIntoRhs other = False
\end{code}
import CoreSyn
-import CmdLineOpts ( opt_D_verbose_core2core, opt_D_simplifier_stats )
+import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_simpl_stats )
import ErrUtils ( dumpIfSet )
import CostCentre ( dupifyCC, CostCentre )
import Id ( Id )
let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
- dumpIfSet opt_D_simplifier_stats "FloatOut stats:"
+ dumpIfSet opt_D_dump_simpl_stats "FloatOut stats:"
(hcat [ int tlets, ptext SLIT(" Lets floated to top level; "),
int ntlets, ptext SLIT(" Lets floated elsewhere; from "),
int lams, ptext SLIT(" Lambda groups")]);
import CmdLineOpts ( opt_D_verbose_core2core, opt_LiberateCaseThreshold )
import CoreLint ( beginPass, endPass )
import CoreSyn
-import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..) )
+import CoreUnfold ( calcUnfoldingGuidance, couldBeSmallEnoughToInline )
import Var ( Id )
import VarEnv
import Maybes
-- [May 98: all this is now handled by SimplCore.tidyCore]
rhs_small_enough rhs
- = case (calcUnfoldingGuidance lIBERATE_BOMB_SIZE rhs) of
- UnfoldNever -> False
- _ -> True -- we didn't BOMB, so it must be OK
+ = couldBeSmallEnoughToInline (calcUnfoldingGuidance lIBERATE_BOMB_SIZE rhs)
lIBERATE_BOMB_SIZE = bombOutSize env
\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
-\section[MagicUFs]{Magic unfoldings that the simplifier knows about}
-
-\begin{code}
-module MagicUFs (
- MagicUnfoldingFun, -- absolutely abstract
-
- mkMagicUnfoldingFun,
- applyMagicUnfoldingFun
- ) where
-
-#include "HsVersions.h"
-
-import CoreSyn
-import SimplMonad ( SimplM, SimplCont )
-import Type ( mkFunTys )
-import TysWiredIn ( mkListTy )
-import Unique ( Unique{-instances-} )
-import Util ( assoc, zipWith3Equal, nOfThem )
-import Panic ( panic )
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Types, etc., for magic-unfolding functions}
-%* *
-%************************************************************************
-
-\begin{code}
-data MagicUnfoldingFun
- = MUF ( SimplCont -> Maybe (SimplM CoreExpr))
- -- Just result, or Nothing
-\end{code}
-
-Give us a value's @Unique@, we'll give you back the corresponding MUF.
-\begin{code}
-mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun
-
-mkMagicUnfoldingFun tag
- = assoc "mkMagicUnfoldingFun" magic_UFs_table tag
-
-magic_UFs_table = panic "MagicUFs.magic_UFs_table:ToDo"
-\end{code}
-
-Give us an MUF and stuff to apply it to, and we'll give you back the answer.
-
-\begin{code}
-applyMagicUnfoldingFun
- :: MagicUnfoldingFun
- -> SimplCont
- -> Maybe (SimplM CoreExpr)
-
-applyMagicUnfoldingFun (MUF fun) cont = fun cont
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The table of actual magic unfoldings}
-%* *
-%************************************************************************
-
-\begin{code}
-{- LATER:
-
-magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)]
-
-magic_UFs_table
- = [(SLIT("augment"), MUF augment_fun),
- (SLIT("build"), MUF build_fun),
- (SLIT("foldl"), MUF foldl_fun),
- (SLIT("foldr"), MUF foldr_fun),
- (SLIT("unpackFoldrPS__"), MUF unpack_foldr_fun),
- (SLIT("unpackAppendPS__"), MUF unpack_append_fun)]
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Unfolding function for @append@}
-%* *
-%************************************************************************
-
-\begin{code}
--- First build, the way we express our lists.
-
-build_fun :: SimplEnv
- -> [CoreArg]
- -> Maybe (SimplM CoreExpr)
-build_fun env [TypeArg ty,ValArg (VarArg e)]
- | switchIsSet env SimplDoInlineFoldrBuild
- = Just result
- where
- tyL = mkListTy ty
- ourCons = CoTyApp (Var consDataCon) ty
- ourNil = CoTyApp (Var nilDataCon) ty
-
- result = newIds [ mkFunTys [ty, tyL] tyL, tyL ] `thenSmpl` \ [c,n] ->
- returnSmpl(Let (NonRec c ourCons)
- (Let (NonRec n ourNil)
- (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n)))
-
--- ToDo: add `build' without an argument instance.
--- This is strange, because of g's type.
-build_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
- Nothing
-\end{code}
-
-\begin{code}
-augment_fun :: SimplEnv
- -> [CoreArg]
- -> Maybe (SimplM CoreExpr)
-
-augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil]
- | switchIsSet env SimplDoInlineFoldrBuild
- = Just result
- where
- tyL = mkListTy ty
- ourCons = CoTyApp (Var consDataCon) ty
- result = newId (mkFunTys [ty, tyL] tyL) `thenSmpl` \ c ->
- returnSmpl (Let (NonRec c ourCons)
- (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil))
--- ToDo: add `build' without an argument instance.
--- This is strange, because of g's type.
-
-augment_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
- Nothing
-\end{code}
-
-Now foldr, the way we consume lists.
-
-\begin{code}
-foldr_fun :: SimplEnv
- -> [CoreArg]
- -> Maybe (SimplM CoreExpr)
-
-foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
- | do_fb_red && isConsFun env arg_k && isNilForm env arg_z
- -- foldr (:) [] ==> id
- -- this transformation is *always* benificial
- -- cf. foldr (:) [] (build g) == g (:) []
- -- with foldr (:) [] (build g) == build g
- -- after unfolding build, they are the same thing.
- = Just (tick Foldr_Cons_Nil `thenSmpl_`
- newId (mkListTy ty1) `thenSmpl` \ x ->
- returnSmpl({-trace "foldr (:) []"-} (mkGenApp (Lam x (Var x)) rest_args))
- )
- where
- do_fb_red = switchIsSet env SimplDoFoldrBuild
-
-foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
- | do_fb_red && isNilForm env arg_list
- -- foldr f z [] = z
- -- again another short cut, helps with unroling of constant lists
- = Just (tick Foldr_Nil `thenSmpl_`
- returnSmpl (argToExpr arg_z)
- )
-
- | do_fb_red && arg_list_isBuildForm
- -- foldr k z (build g) ==> g k z
- -- this next line *is* the foldr/build rule proper.
- = Just (tick FoldrBuild `thenSmpl_`
- returnSmpl (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args))
- )
-
- | do_fb_red && arg_list_isAugmentForm
- -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
- -- this next line *is* the foldr/augment rule proper.
- = Just (tick FoldrAugment `thenSmpl_`
- newId ty2 `thenSmpl` \ v ->
- returnSmpl (
- Let (NonRec v (mkGenApp (Var foldrId)
- [TypeArg ty1,TypeArg ty2,
- ValArg arg_k,
- ValArg arg_z,
- ValArg h]))
- (mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args)))
- )
-
- | do_fb_red && arg_list_isListForm
- -- foldr k z (a:b:c:rest) =
- -- (\ f -> f a (f b (f c (foldr f z rest)))) k rest_args
- -- NB: 'k' is used just one by foldr, but 'f' is used many
- -- times inside the list structure. This means that
- -- 'f' needs to be inside a lambda, to make sure the simplifier
- -- realises this.
- --
- -- The structure of
- -- f a (f b (f c (foldr f z rest)))
- -- in core becomes:
- -- let ele_1 = foldr f z rest
- -- ele_2 = f c ele_1
- -- ele_3 = f b ele_2
- -- in f a ele_3
- --
- = Just (tick Foldr_List `thenSmpl_`
- newIds (
- mkFunTys [ty1, ty2] ty2 :
- nOfThem (length the_list) ty2
- ) `thenSmpl` \ (f_id:ele_id1:ele_ids) ->
- let
- fst_bind = NonRec
- ele_id1
- (mkGenApp (Var foldrId)
- [TypeArg ty1,TypeArg ty2,
- ValArg (VarArg f_id),
- ValArg arg_z,
- ValArg the_tl])
- rest_binds = zipWith3Equal "Foldr:rest_binds"
- (\ e v e' -> NonRec e (mkRhs v e'))
- ele_ids
- (reverse (tail the_list))
- (init (ele_id1:ele_ids))
- mkRhs v e = App (App (Var f_id) v) (VarArg e)
- core_list = foldr
- Let
- (mkRhs (head the_list) (last (ele_id1:ele_ids)))
- (fst_bind:rest_binds)
- in
- returnSmpl (mkGenApp (Lam f_id core_list) (ValArg arg_k:rest_args))
- )
-
-
- --
-
- | do_fb_red && arg_list_isStringForm -- ok, its a string!
- -- foldr f z "foo" => unpackFoldrPS__ f z "foo"#
- = Just (tick Str_FoldrStr `thenSmpl_`
- returnSmpl (mkGenApp (Var unpackCStringFoldrId)
- (TypeArg ty2:
- ValArg (LitArg (MachStr str_val)):
- ValArg arg_k:
- ValArg arg_z:
- rest_args))
- )
- where
- do_fb_red = switchIsSet env SimplDoFoldrBuild
-
- arg_list_isStringForm = maybeToBool stringForm
- stringForm = getStringForm env arg_list
- (Just str_val) = stringForm
-
- arg_list_isBuildForm = maybeToBool buildForm
- buildForm = getBuildForm env arg_list
- (Just g) = buildForm
-
- arg_list_isAugmentForm = maybeToBool augmentForm
- augmentForm = getAugmentForm env arg_list
- (Just (g',h)) = augmentForm
-
- arg_list_isListForm = maybeToBool listForm
- listForm = getListForm env arg_list
- (Just (the_list,the_tl)) = listForm
-{-
- arg_list_isAppendForm = maybeToBool appendForm
- appendForm = getAppendForm env arg_list
- (Just (xs,ys)) = appendForm
--}
-
-foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
- | doing_inlining && isConsFun env arg_k && not dont_fold_back_append
- -- foldr (:) z xs = xs ++ z
- = Just (tick Foldr_Cons `thenSmpl_`
- newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
- returnSmpl (mkGenApp
- (Lam z (Lam x (mkGenApp
- (Var appendId) [
- TypeArg ty1,
- ValArg (VarArg x),
- ValArg (VarArg z)]))
- rest_args))
- )
-
- | doing_inlining && (isInterestingArg env arg_k
- || isConsFun env arg_k)
- -- foldr k args =
- -- (\ f z xs ->
- -- letrec
- -- h x = case x of
- -- [] -> z
- -- (a:b) -> f a (h b)
- -- in
- -- h xs) k args
- --
--- tick FoldrInline `thenSmpl_`
- = Just (newIds [
- ty1, -- a :: t1
- mkListTy ty1, -- b :: [t1]
- ty2, -- v :: t2
- mkListTy ty1, -- x :: t1
- mkFunTys [mkListTy ty1] ty2,
- -- h :: [t1] -> t2
- mkFunTys [ty1, ty2] ty2,
- -- f
- ty2, -- z
- mkListTy ty1 -- xs
- ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
- let
- h_rhs = (Lam x (Case (Var x)
- (AlgAlts
- [(nilDataCon,[],argToExpr (VarArg z)),
- (consDataCon,[a,b],body)]
- NoDefault)))
- body = Let (NonRec v (App (Var h) (VarArg b)))
- (App (App (argToExpr (VarArg f))
- (VarArg a))
- (VarArg v))
- in
- returnSmpl (
- mkGenApp
- (Lam f (Lam z (Lam xs
- (Let (Rec [(h,h_rhs)])
- (App (Var h) (VarArg xs))))))
- (ValArg arg_k:rest_args))
- )
- where
- doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
- dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
-
-foldr_fun _ _ = Nothing
-
-isConsFun :: SimplEnv -> CoreArg -> Bool
-isConsFun env (VarArg v)
- = case lookupUnfolding env v of
- SimpleUnfolding _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _
- | con == consDataCon && x==x' && y==y'
- -> ASSERT ( length tys == 1 ) True
- _ -> False
-isConsFun env _ = False
-
-isNilForm :: SimplEnv -> CoreArg -> Bool
-isNilForm env (VarArg v)
- = case lookupUnfolding env v of
- SimpleUnfolding _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True
- SimpleUnfolding _ (Lit (NoRepStr s)) _ | _NULL_ s -> True
- _ -> False
-isNilForm env _ = False
-
-getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
-getBuildForm env (VarArg v)
- = case lookupUnfolding env v of
- SimpleUnfolding False _ _ _ -> Nothing
- -- not allowed to inline :-(
- SimpleUnfolding _ (App (CoTyApp (Var bld) _) (VarArg g)) _
- | bld == buildId -> Just g
- SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
- (VarArg g)) h) _
- | bld == augmentId && isNilForm env h -> Just g
- _ -> Nothing
-getBuildForm env _ = Nothing
-
-
-
-getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
-getAugmentForm env (VarArg v)
- = case lookupUnfolding env v of
- SimpleUnfolding False _ _ _ -> Nothing
- -- not allowed to inline :-(
- SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
- (VarArg g)) h) _
- | bld == augmentId -> Just (g,h)
- _ -> Nothing
-getAugmentForm env _ = Nothing
-
-getStringForm :: SimplEnv -> CoreArg -> Maybe FAST_STRING
-getStringForm env (LitArg (NoRepStr str)) = Just str
-getStringForm env _ = Nothing
-
-{-
-getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id)
-getAppendForm env (VarArg v) =
- case lookupUnfolding env v of
- SimpleUnfolding False _ _ _ -> Nothing -- not allowed to inline :-(
- SimpleUnfolding _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
- | fld == foldrId && isConsFun env con -> Just (xs,ys)
- _ -> Nothing
-getAppendForm env _ = Nothing
--}
-
---
--- this gets a list of the form a : b : c : d and returns ([a,b,c],d)
--- it natuarally follows that [a,b,c] => ([a,b,c],e), where e = []
---
-
-getListForm
- :: SimplEnv
- -> CoreArg
- -> Maybe ([CoreArg],CoreArg)
-getListForm env (VarArg v)
- = case lookupUnfolding env v of
- SimpleUnfolding _ (Con id [ty_arg,head,tail]) _
- | id == consDataCon ->
- case getListForm env tail of
- Nothing -> Just ([head],tail)
- Just (lst,new_tail) -> Just (head:lst,new_tail)
- _ -> Nothing
-getListForm env _ = Nothing
-
-isInterestingArg :: SimplEnv -> CoreArg -> Bool
-isInterestingArg env (VarArg v)
- = case lookupUnfolding env v of
- SimpleUnfolding False _ _ UnfoldNever -> False
- SimpleUnfolding _ exp guide -> True
- _ -> False
-isInterestingArg env _ = False
-
-foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
- | do_fb_red && isNilForm env arg_list
- -- foldl f z [] = z
- -- again another short cut, helps with unroling of constant lists
- = Just (tick Foldl_Nil `thenSmpl_`
- returnSmpl (argToExpr arg_z)
- )
-
- | do_fb_red && arg_list_isBuildForm
- -- foldl t1 t2 k z (build t3 g) ==>
- -- let c {- INLINE -} = \ b g' a -> g' (f a b)
- -- n {- INLINE -} = \ a -> a
- -- in g t1 c n z
- -- this next line *is* the foldr/build rule proper.
- = Just(tick FoldlBuild `thenSmpl_`
- -- c :: t2 -> (t1 -> t1) -> t1 -> t1
- -- n :: t1 -> t1
- newIds [
- {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
- {- pre_n -} mkFunTys [ty1] ty1,
- {- b -} ty2,
- {- g' -} mkFunTys [ty1] ty1,
- {- a -} ty1,
- {- a' -} ty1,
- {- t -} ty1
- ] `thenSmpl` \ [pre_c,
- pre_n,
- b,
- g',
- a,
- a',
- t] ->
-
- let
- c = addInlinePragma pre_c
- c_rhs = Lam b (Lam g' (Lam a
- (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
- (App (Var g') (VarArg t)))))
- n = addInlinePragma pre_n
- n_rhs = Lam a' (Var a')
- in
- returnSmpl (Let (NonRec c c_rhs) $
- Let (NonRec n n_rhs) $
- mkGenApp (Var g)
- (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
- :ValArg arg_z:rest_args))
- )
-
- | do_fb_red && arg_list_isAugmentForm
- -- foldl t1 t2 k z (augment t3 g h) ==>
- -- let c {- INLINE -} = \ b g' a -> g' (f a b)
- -- n {- INLINE -} = \ a -> a
- -- r {- INLINE -} = foldr t2 (t1 -> t1) c n h
- -- in g t1 c r z
- -- this next line *is* the foldr/build rule proper.
- = Just (tick FoldlAugment `thenSmpl_`
- -- c :: t2 -> (t1 -> t1) -> t1 -> t1
- -- n :: t1 -> t1
- newIds [
- {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
- {- pre_n -} mkFunTys [ty1] ty1,
- {- pre_r -} mkFunTys [ty1] ty1,
- {- b -} ty2,
- {- g_ -} mkFunTys [ty1] ty1,
- {- a -} ty1,
- {- a' -} ty1,
- {- t -} ty1
- ] `thenSmpl` \ [pre_c,
- pre_n,
- pre_r,
- b,
- g_,
- a,
- a',
- t] ->
-
- let
- c = addInlinePragma pre_c
- c_rhs = Lam b (Lam g_ (Lam a
- (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
- (App (Var g_) (VarArg t)))))
- n = addInlinePragma pre_n
- n_rhs = Lam a' (Var a')
- r = addInlinePragma pre_r
- r_rhs = mkGenApp (Var foldrId)
- [TypeArg ty2,TypeArg (mkFunTys [ty1] ty1),
- ValArg (VarArg c),
- ValArg (VarArg n),
- ValArg h]
- in
- returnSmpl (Let (NonRec c c_rhs) $
- Let (NonRec n n_rhs) $
- Let (NonRec r r_rhs) $
- mkGenApp (Var g')
- (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg r)
- :ValArg arg_z:rest_args))
- )
-
- | do_fb_red && arg_list_isListForm
- -- foldl k z (a:b:c:rest) =
- -- (\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
- -- NB: 'k' is used just one by foldr, but 'f' is used many
- -- times inside the list structure. This means that
- -- 'f' needs to be inside a lambda, to make sure the simplifier
- -- realises this.
- --
- -- The structure of
- -- foldl f (f (f (f z a) b) c) rest
- -- f a (f b (f c (foldr f z rest)))
- -- in core becomes:
- -- let ele_1 = f z a
- -- ele_2 = f ele_1 b
- -- ele_3 = f ele_2 c
- -- in foldl f ele_3 rest
- --
- = Just (tick Foldl_List `thenSmpl_`
- newIds (
- mkFunTys [ty1, ty2] ty1 :
- nOfThem (length the_list) ty1
- ) `thenSmpl` \ (f_id:ele_ids) ->
- let
- rest_binds = zipWith3Equal "foldl:rest_binds"
- (\ e v e' -> NonRec e (mkRhs v e'))
- ele_ids -- :: [Id]
- the_list -- :: [CoreArg]
- (init (arg_z:map VarArg ele_ids)) -- :: [CoreArg]
- mkRhs v e = App (App (Var f_id) e) v
-
- last_bind = mkGenApp (Var foldlId)
- [TypeArg ty1,TypeArg ty2,
- ValArg (VarArg f_id),
- ValArg (VarArg (last ele_ids)),
- ValArg the_tl]
- core_list = foldr
- Let
- last_bind
- rest_binds
- in
- returnSmpl (mkGenApp (Lam f_id core_list)
- (ValArg arg_k:rest_args))
- )
-
- where
- do_fb_red = switchIsSet env SimplDoFoldrBuild
-
- arg_list_isAugmentForm = maybeToBool augmentForm
- augmentForm = getAugmentForm env arg_list
- (Just (g',h)) = augmentForm
-
- arg_list_isBuildForm = maybeToBool buildForm
- buildForm = getBuildForm env arg_list
- (Just g) = buildForm
-
- arg_list_isListForm = maybeToBool listForm
- listForm = getListForm env arg_list
- (Just (the_list,the_tl)) = listForm
-
-{-
- arg_list_isAppendForm = maybeToBool appendForm
- appendForm = getAppendForm env arg_list
- (Just (xs,ys)) = appendForm
--}
-
-foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
- | doing_inlining && (isInterestingArg env arg_k
- || isConsFun env arg_k)
- -- foldl k args =
- -- (\ f z xs ->
- -- letrec
- -- h x r = case x of
- -- [] -> r
- -- (a:b) -> h b (f r a)
- -- in
- -- h xs z) k args
- --
- = Just (
--- tick FoldrInline `thenSmpl_`
- newIds [
- ty2, -- a :: t1
- mkListTy ty2, -- b :: [t1]
- ty1, -- v :: t2
- mkListTy ty2, -- x :: t1
- mkFunTys [mkListTy ty2, ty1] ty1,
- -- h :: [t2] -> t1 -> t1
- mkFunTys [ty1, ty2] ty1,
- -- f
- ty1, -- z
- mkListTy ty2, -- xs
- ty1 -- r
- ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
- let
- h_rhs = (Lam x (Lam r (Case (Var x))
- (AlgAlts
- [(nilDataCon,[],argToExpr (VarArg r)),
- (consDataCon,[a,b],body)]
- NoDefault)))
- body = Let (NonRec v (App (App (Var f) (VarArg r))
- (VarArg a)))
- (App (App (argToExpr (VarArg h))
- (VarArg b))
- (VarArg v))
- in
- returnSmpl (
- (mkGenApp
- (Lam f (Lam z (Lam xs
- (Let (Rec [(h,h_rhs)])
- (App (App (Var h) (VarArg xs))
- (VarArg z))))))
- (ValArg arg_k:rest_args))
- )
- where
- doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
-
-foldl_fun env _ = Nothing
-\end{code}
-
-
-\begin{code}
---
--- Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"#
---
-unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z]
- | switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k
- = Just (tick Str_UnpackCons `thenSmpl_`
- returnSmpl (mkGenApp (Var unpackCStringAppendId)
- [ValArg str,
- ValArg arg_z])
- )
-unpack_foldr_fun env _ = Nothing
-
-unpack_append_fun env
- [ValArg (LitArg (MachStr str_val)),ValArg arg_z]
- | switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
- = Just (tick Str_UnpackNil `thenSmpl_`
- returnSmpl (Lit (NoRepStr str_val))
- )
-unpack_append_fun env _ = Nothing
--}
-\end{code}
\begin{code}
module OccurAnal (
occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr,
- markBinderInsideLambda
+ markBinderInsideLambda, tagBinders,
+ UsageDetails
) where
#include "HsVersions.h"
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
-import CoreUtils ( exprIsTrivial, idSpecVars )
+import CoreFVs ( idRuleVars )
+import CoreUtils ( exprIsTrivial )
import Const ( Con(..), Literal(..) )
-import Id ( idWantsToBeINLINEd, isSpecPragmaId,
+import Id ( isSpecPragmaId,
getInlinePragma, setInlinePragma,
- omitIfaceSigForId,
+ isExportedId, modifyIdInfo, idInfo,
getIdSpecialisation,
idType, idUnique, Id
)
-import IdInfo ( InlinePragInfo(..), OccInfo(..) )
-import SpecEnv ( isEmptySpecEnv )
+import IdInfo ( InlinePragInfo(..), OccInfo(..), copyIdInfo )
import VarSet
import VarEnv
-import PrelInfo ( noRepStrIds, noRepIntegerIds )
-import Name ( isExported, isLocallyDefined )
+import ThinAir ( noRepStrIds, noRepIntegerIds )
+import Name ( isLocallyDefined )
import Type ( splitFunTy_maybe, splitForAllTys )
import Maybes ( maybeToBool )
import Digraph ( stronglyConnCompR, SCC(..) )
-import Unique ( u2i )
+import Unique ( u2i, buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
import UniqFM ( keysUFM )
-import Util ( zipWithEqual, mapAndUnzip )
+import Util ( zipWithEqual, mapAndUnzip, count )
import Outputable
\end{code}
Here's the externally-callable interface:
\begin{code}
-occurAnalyseBinds
- :: (SimplifierSwitch -> Bool)
- -> [CoreBind]
- -> [CoreBind]
-
-occurAnalyseBinds simplifier_sw_chkr binds
- = binds'
- where
- (_, _, binds') = occAnalTop initial_env binds
-
- initial_env = OccEnv (simplifier_sw_chkr IgnoreINLINEPragma)
- (\id -> isLocallyDefined id) -- Anything local is interesting
- emptyVarSet
-\end{code}
-
-
-\begin{code}
occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting
-> CoreExpr
-> (IdEnv BinderInfo, -- Occ info for interesting free vars
occurAnalyseExpr interesting expr
= occAnal initial_env expr
where
- initial_env = OccEnv False {- Do not ignore INLINE Pragma -}
- interesting
- emptyVarSet
+ initial_env = OccEnv interesting emptyVarSet []
occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr
occurAnalyseGlobalExpr expr
This save a gratuitous jump
(from \tr{x_exported} to \tr{x_local}), and makes strictness
information propagate better.
-This used to happen in the final phase, but its tidier to do it here.
+This used to happen in the final phase, but it's tidier to do it here.
If more than one exported thing is equal to a local thing (i.e., the
because we might elminate a binding that's mentioned in the
unfolding for something.
-
\begin{code}
-occAnalTop :: OccEnv -- What's in scope
- -> [CoreBind]
- -> (IdEnv BinderInfo, -- Occurrence info
- IdEnv Id, -- Indirection elimination info
- [CoreBind]
- )
-
-occAnalTop env [] = (emptyDetails, emptyVarEnv, [])
-
--- Special case for eliminating indirections
--- Note: it's a shortcoming that this only works for
--- non-recursive bindings. Elminating indirections
--- makes perfect sense for recursive bindings too, but
--- it's more complicated to implement, so I haven't done so
-
-occAnalTop env (bind : binds)
- = case bind of
- NonRec exported_id (Var local_id) | shortMeOut ind_env exported_id local_id
- -> -- Aha! An indirection; let's eliminate it!
- (scope_usage, ind_env', binds')
+occurAnalyseBinds :: [CoreBind] -> [CoreBind]
+
+occurAnalyseBinds binds
+ = binds'
+ where
+ (_, _, binds') = go initialTopEnv binds
+
+ go :: OccEnv -> [CoreBind]
+ -> (UsageDetails, -- Occurrence info
+ IdEnv Id, -- Indirection elimination info
+ [CoreBind])
+
+ go env [] = (emptyDetails, emptyVarEnv, [])
+
+ go env (bind : binds)
+ = let
+ new_env = env `addNewCands` (bindersOf bind)
+ (scope_usage, ind_env, binds') = go new_env binds
+ (final_usage, new_binds) = occAnalBind env (zapBind ind_env bind) scope_usage
+ -- NB: I zap before occur-analysing, so
+ -- I don't need to worry about getting the
+ -- occ info on the new bindings right.
+ in
+ case bind of
+ NonRec exported_id (Var local_id)
+ | shortMeOut ind_env exported_id local_id
+ -- Special case for eliminating indirections
+ -- Note: it's a shortcoming that this only works for
+ -- non-recursive bindings. Elminating indirections
+ -- makes perfect sense for recursive bindings too, but
+ -- it's more complicated to implement, so I haven't done so
+ -> (scope_usage, ind_env', binds')
where
ind_env' = extendVarEnv ind_env local_id exported_id
- other -> -- Ho ho! The normal case
+ other -> -- Ho ho! The normal case
(final_usage, ind_env, new_binds ++ binds')
- where
- (final_usage, new_binds) = occAnalBind env (zap_bind bind) scope_usage
- where
- new_env = env `addNewCands` (bindersOf bind)
- (scope_usage, ind_env, binds') = occAnalTop new_env binds
-
- -- Deal with any indirections
- zap_bind (NonRec bndr rhs)
- | bndr `elemVarEnv` ind_env = Rec (zap (bndr,rhs))
- -- The Rec isn't strictly necessary, but it's convenient
- zap_bind (Rec pairs)
- | or [id `elemVarEnv` ind_env | (id,_) <- pairs] = Rec (concat (map zap pairs))
-
- zap_bind bind = bind
+
+initialTopEnv = OccEnv isLocallyDefined -- Anything local is interesting
+ emptyVarSet
+ []
- zap pair@(bndr,rhs) = case lookupVarEnv ind_env bndr of
- Nothing -> [pair]
- Just exported_id -> [(bndr, Var exported_id),
- (exported_id, rhs)]
+-- Deal with any indirections
+zapBind ind_env (NonRec bndr rhs)
+ | bndr `elemVarEnv` ind_env = Rec (zap ind_env (bndr,rhs))
+ -- The Rec isn't strictly necessary, but it's convenient
+zapBind ind_env (Rec pairs)
+ | or [id `elemVarEnv` ind_env | (id,_) <- pairs] = Rec (concat (map (zap ind_env) pairs))
+
+zapBind ind_env bind = bind
+
+zap ind_env pair@(bndr,rhs)
+ = case lookupVarEnv ind_env bndr of
+ Nothing -> [pair]
+ Just exported_id -> [(bndr, Var exported_id),
+ (exported_id_w_info, rhs)]
+ where
+ exported_id_w_info = modifyIdInfo (copyIdInfo (idInfo bndr)) exported_id
+ -- See notes with copyIdInfo about propagating IdInfo from
+ -- one to t'other
+
shortMeOut ind_env exported_id local_id
- = isExported exported_id && -- Only if this is exported
+ = isExportedId exported_id && -- Only if this is exported
isLocallyDefined local_id && -- Only if this one is defined in this
-- module, so that we *can* change its
-- binding to be the exported thing!
- not (isExported local_id) && -- Only if this one is not itself exported,
+ not (isExportedId local_id) && -- Only if this one is not itself exported,
-- since the transformation will nuke it
- not (omitIfaceSigForId local_id) && -- Don't do the transformation if rhs_id is
- -- something like a constructor, whose
- -- definition is implicitly exported and
- -- which must not vanish.
- -- To illustrate the preceding check consider
- -- data T = MkT Int
- -- mkT = MkT
- -- f x = MkT (x+1)
- -- Here, we'll make a local, non-exported, defn for MkT, and without the
- -- above condition we'll transform it to:
- -- mkT = \x. MkT [x]
- -- f = \y. mkT (y+1)
- -- This is bad because mkT will get the IdDetails of MkT, and won't
- -- be exported. Also the code generator won't make a definition for
- -- the MkT constructor.
- -- Slightly gruesome, this.
-
-
not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
\end{code}
score :: Node Details2 -> Int -- Higher score => less likely to be picked as loop breaker
score ((bndr, rhs), _, _)
| exprIsTrivial rhs &&
- not (isExported bndr) = 3 -- Practically certain to be inlined
- | inlineCandidate bndr = 3 -- Likely to be inlined
+ not (isExportedId bndr) = 3 -- Practically certain to be inlined
+ | inlineCandidate bndr rhs = 3 -- Likely to be inlined
| not_fun_ty (idType bndr) = 2 -- Data types help with cases
- | not (isEmptySpecEnv (getIdSpecialisation bndr)) = 1
- -- Avoid things with a SpecEnv; we'd like
- -- to take advantage of the SpecEnv in the subsequent bindings
+ | not (isEmptyCoreRules (getIdSpecialisation bndr)) = 1
+ -- Avoid things with specialisations; we'd like
+ -- to take advantage of them in the subsequent bindings
| otherwise = 0
- inlineCandidate :: Id -> Bool
- inlineCandidate id
- = case getInlinePragma id of
- IWantToBeINLINEd -> True
- IMustBeINLINEd -> True
- ICanSafelyBeINLINEd _ _ -> True
- other -> False
+ inlineCandidate :: Id -> CoreExpr -> Bool
+ inlineCandidate id (Note InlineMe _) = True
+ inlineCandidate id rhs = case getInlinePragma id of
+ IMustBeINLINEd -> True
+ ICanSafelyBeINLINEd _ _ -> True
+ other -> False
-- Real example (the Enum Ordering instance from PrelBase):
-- rec f = \ x -> case d of (p,q,r) -> p x
[March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
[June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec.
-[March 98] A new wrinkle is that if the binder has specialisations inside
-it then we count the specialised Ids as "extra rhs's". That way
-the "parent" keeps the specialised "children" alive. If the parent
-dies (because it isn't referenced any more), then the children will
-die too unless they are already referenced directly.
\begin{code}
occAnalRhs :: OccEnv
-> Id -> CoreExpr -- Binder and rhs
-> (UsageDetails, CoreExpr)
-{- DELETED SLPJ June 98: seems quite bogus to me
-occAnalRhs env id (Var v)
- | isCandidate env v
- = (unitVarEnv v (markMany (funOccurrence 0)), Var v)
-
- | otherwise
- = (emptyDetails, Var v)
--}
-
occAnalRhs env id rhs
- | idWantsToBeINLINEd id
- = (mapVarEnv markMany total_usage, rhs')
-
- | otherwise
- = (total_usage, rhs')
-
+ = (final_usage, rhs')
where
(rhs_usage, rhs') = occAnal env rhs
- lazy_rhs_usage = mapVarEnv markLazy rhs_usage
- total_usage = foldVarSet add lazy_rhs_usage spec_ids
- add v u = addOneOcc u v noBinderInfo -- Give a non-committal binder info
- -- (i.e manyOcc) because many copies
- -- of the specialised thing can appear
- spec_ids = idSpecVars id
-\end{code}
+ -- [March 98] A new wrinkle is that if the binder has specialisations inside
+ -- it then we count the specialised Ids as "extra rhs's". That way
+ -- the "parent" keeps the specialised "children" alive. If the parent
+ -- dies (because it isn't referenced any more), then the children will
+ -- die too unless they are already referenced directly.
+
+ final_usage = foldVarSet add rhs_usage (idRuleVars id)
+ add v u = addOneOcc u v noBinderInfo -- Give a non-committal binder info
+ -- (i.e manyOcc) because many copies
+ -- of the specialised thing can appear
\end{code}
Expressions
occAnal env (Type t) = (emptyDetails, Type t)
-occAnal env (Var v)
- | isCandidate env v = (unitVarEnv v funOccZero, Var v)
- | otherwise = (emptyDetails, Var v)
+occAnal env (Var v)
+ = (var_uds, Var v)
+ where
+ var_uds | isCandidate env v = unitVarEnv v funOccZero
+ | otherwise = emptyDetails
+
+ -- At one stage, I gathered the idRuleVars for v here too,
+ -- which in a way is the right thing to do.
+ -- But that went wrong right after specialisation, when
+ -- the *occurrences* of the overloaded function didn't have any
+ -- rules in them, so the *specialised* versions looked as if they
+ -- weren't used at all.
+
\end{code}
We regard variables that occur as constructor arguments as "dangerousToDup":
| otherwise = uds
occAnal env (Con con args)
- = case mapAndUnzip (occAnal env) args of { (arg_uds_s, args') ->
+ = case occAnalArgs env args of { (arg_uds, args') ->
let
- arg_uds = foldr combineUsageDetails emptyDetails arg_uds_s
-
-- We mark the free vars of the argument of a constructor as "many"
-- This means that nothing gets inlined into a constructor argument
-- position, which is what we want. Typically those constructor
-- arguments are just variables, or trivial expressions.
final_arg_uds = case con of
DataCon _ -> mapVarEnv markMany arg_uds
- PrimOp _ -> mapVarEnv markLazy arg_uds
other -> arg_uds
in
(final_arg_uds, Con con args')
\end{code}
\begin{code}
+occAnal env (Note InlineMe body)
+ = case occAnal env body of { (usage, body') ->
+ (mapVarEnv markMany usage, Note InlineMe body')
+ }
+
occAnal env (Note note@(SCC cc) body)
= case occAnal env body of { (usage, body') ->
(mapVarEnv markInsideSCC usage, Note note body')
\end{code}
\begin{code}
-occAnal env (App fun arg)
- = case occAnal env fun of { (fun_usage, fun') ->
- case occAnal env arg of { (arg_usage, arg') ->
- (fun_usage `combineUsageDetails` mapVarEnv markLazy arg_usage, App fun' arg')
- }}
-
+occAnal env app@(App fun arg)
+ = occAnalApp env (collectArgs app)
+
-- Ignore type variables altogether
-- (a) occurrences inside type lambdas only not marked as InsideLam
-- (b) type variables not in environment
-- Then, the simplifier is careful when partially applying lambdas.
occAnal env expr@(Lam _ _)
- = case occAnal (env `addNewCands` binders) body of { (body_usage, body') ->
+ = case occAnal (env_body `addNewCands` binders) body of { (body_usage, body') ->
let
(final_usage, tagged_binders) = tagBinders body_usage binders
+ really_final_usage = if linear then
+ final_usage
+ else
+ mapVarEnv markInsideLam final_usage
in
- (mapVarEnv markInsideLam final_usage,
+ (really_final_usage,
mkLams tagged_binders body') }
where
- (binders, body) = collectBinders expr
-
+ (binders, body) = collectBinders expr
+ (linear, env_body) = getCtxt env (count isId binders)
occAnal env (Case scrut bndr alts)
= case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') ->
(final_usage, mkLets new_binds body') }}
where
new_env = env `addNewCands` (bindersOf bind)
+
+occAnalArgs env args
+ = case mapAndUnzip (occAnal env) args of { (arg_uds_s, args') ->
+ (foldr combineUsageDetails emptyDetails arg_uds_s, args')}
\end{code}
+Applications are dealt with specially because we want
+the "build hack" to work.
+
+\begin{code}
+-- Hack for build, fold, runST
+occAnalApp env (Var fun, args)
+ = case args_stuff of { (args_uds, args') ->
+ let
+ final_uds = fun_uds `combineUsageDetails` args_uds
+ in
+ (final_uds, mkApps (Var fun) args') }
+ where
+ fun_uniq = idUnique fun
+
+ fun_uds | isCandidate env fun = unitVarEnv fun funOccZero
+ | otherwise = emptyDetails
+
+ args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
+ | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
+ | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
+ | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
+ | otherwise = occAnalArgs env args
+
+occAnalApp env (fun, args)
+ = case occAnal env fun of { (fun_uds, fun') ->
+ case occAnalArgs env args of { (args_uds, args') ->
+ let
+ final_uds = fun_uds `combineUsageDetails` args_uds
+ in
+ (final_uds, mkApps fun' args') }}
+
+appSpecial :: OccEnv -> Int -> CtxtTy -> [CoreExpr] -> (UsageDetails, [CoreExpr])
+appSpecial env n ctxt args
+ = go n args
+ where
+ go n [] = (emptyDetails, []) -- Too few args
+
+ go 1 (arg:args) -- The magic arg
+ = case occAnal (setCtxt env ctxt) arg of { (arg_uds, arg') ->
+ case occAnalArgs env args of { (args_uds, args') ->
+ (combineUsageDetails arg_uds args_uds, arg':args') }}
+
+ go n (arg:args)
+ = case occAnal env arg of { (arg_uds, arg') ->
+ case go (n-1) args of { (args_uds, args') ->
+ (combineUsageDetails arg_uds args_uds, arg':args') }}
+\end{code}
+
+
Case alternatives
~~~~~~~~~~~~~~~~~
\begin{code}
%************************************************************************
\begin{code}
-data OccEnv =
- OccEnv
- Bool -- IgnoreINLINEPragma flag
- -- False <=> OK to use INLINEPragma information
- -- True <=> ignore INLINEPragma information
+-- We gather inforamtion for variables that are either
+-- (a) in scope or
+-- (b) interesting
- (Id -> Bool) -- Tells whether an Id occurrence is interesting,
- -- given the set of in-scope variables
+data OccEnv =
+ OccEnv (Id -> Bool) -- Tells whether an Id occurrence is interesting,
+ IdSet -- In-scope Ids
+ CtxtTy -- Tells about linearity
- IdSet -- In-scope Ids
+type CtxtTy = [Bool]
+ -- [] No info
+ --
+ -- True:ctxt Analysing a function-valued expression that will be
+ -- applied just once
+ --
+ -- False:ctxt Analysing a function-valued expression that may
+ -- be applied many times; but when it is,
+ -- the CtxtTy inside applies
+isCandidate :: OccEnv -> Id -> Bool
+isCandidate (OccEnv ifun cands _) id = id `elemVarSet` cands || ifun id
addNewCands :: OccEnv -> [Id] -> OccEnv
-addNewCands (OccEnv ip ifun cands) ids
- = OccEnv ip ifun (cands `unionVarSet` mkVarSet ids)
+addNewCands (OccEnv ifun cands ctxt) ids
+ = OccEnv ifun (cands `unionVarSet` mkVarSet ids) ctxt
addNewCand :: OccEnv -> Id -> OccEnv
-addNewCand (OccEnv ip ifun cands) id
- = OccEnv ip ifun (extendVarSet cands id)
+addNewCand (OccEnv ifun cands ctxt) id
+ = OccEnv ifun (extendVarSet cands id) ctxt
-isCandidate :: OccEnv -> Id -> Bool
-isCandidate (OccEnv _ ifun cands) id = id `elemVarSet` cands || ifun id
+setCtxt :: OccEnv -> CtxtTy -> OccEnv
+setCtxt (OccEnv ifun cands _) ctxt = OccEnv ifun cands ctxt
+getCtxt :: OccEnv -> Int -> (Bool, OccEnv) -- True <=> this is a linear lambda
+ -- The Int is the number of lambdas
+getCtxt env@(OccEnv ifun cands []) n = (False, env)
+getCtxt (OccEnv ifun cands ctxt) n = (and (take n ctxt), OccEnv ifun cands (drop n ctxt))
+ -- Only return True if *all* the lambdas are linear
type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
unitDetails id info = (unitVarEnv id info :: UsageDetails)
usedIn :: Id -> UsageDetails -> Bool
-v `usedIn` details = isExported v
- || v `elemVarEnv` details
- || isSpecPragmaId v
+v `usedIn` details = isExportedId v || v `elemVarEnv` details
tagBinders :: UsageDetails -- Of scope
-> [Id] -- Binders
ICanSafelyBeINLINEd _ _ -> new_bndr -- from the previous iteration of
IAmALoopBreaker -> new_bndr -- the occurrence analyser
- IAmASpecPragmaId -> bndr -- Don't ever overwrite or drop these as dead
-
other | its_now_dead -> new_bndr -- Overwrite the others iff it's now dead
| otherwise -> bndr
new_prag = occInfoToInlinePrag occ_info
occ_info
- | isExported bndr = noBinderInfo
+ | isExportedId bndr = noBinderInfo
-- Don't use local usage info for visible-elsewhere things
-- But NB that we do set NoInlinePragma for exported things
-- thereby nuking any IAmALoopBreaker from a previous pass.
InstTyEnv(..)
)
import MkId ( mkSysLocal )
-import Id ( idType, idName, mkUserId )
+import Id ( idType, idName, mkVanillaId )
import UniqSupply
import Util
let
new_name = mkCompoundName SLIT("$sat") unique (idName id)
in
- (mkUserId new_name ty, env) }
+ (mkVanillaId new_name ty, env) }
getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
getArgLists expr
%
\section{SetLevels}
-We attach binding levels to Core bindings, in preparation for floating
-outwards (@FloatOut@).
+ ***************************
+ Overview
+ ***************************
+
+* We attach binding levels to Core bindings, in preparation for floating
+ outwards (@FloatOut@).
+
+* We also let-ify many expressions (notably case scrutinees), so they
+ will have a fighting chance of being floated sensible.
+
+* We clone the binders of any floatable let-binding, so that when it is
+ floated out it will be unique. (This used to be done by the simplifier
+ but the latter now only ensures that there's no shadowing.)
+
-We also let-ify many applications (notably case scrutinees), so they
-will have a fighting chance of being floated sensible.
\begin{code}
module SetLevels (
import CoreSyn
-import CoreUtils ( coreExprType, exprIsTrivial, idFreeVars, exprIsBottom
- )
-import FreeVars -- all of it
+import CoreUtils ( coreExprType, exprIsTrivial, exprIsBottom )
+import CoreFVs -- all of it
import Id ( Id, idType, mkSysLocal )
-import Var ( IdOrTyVar )
+import Var ( IdOrTyVar, Var, setVarUnique )
import VarEnv
import VarSet
import Type ( isUnLiftedType, mkTyVarTys, mkForAllTys, Type )
import VarSet
import VarEnv
-import UniqSupply ( initUs_, thenUs, returnUs, mapUs, mapAndUnzipUs, getUniqueUs,
- mapAndUnzip3Us, UniqSM, UniqSupply )
+import UniqSupply
import Maybes ( maybeToBool )
import Util ( zipWithEqual, zipEqual )
import Outputable
incMinorLvl Top = Level 0 1
incMinorLvl (Level major minor) = Level major (minor+1)
+unTopify :: Type -> Level -> Level
+unTopify ty lvl
+ | isUnLiftedType ty = case lvl of
+ Top -> Level 0 0 -- Unboxed floats can't go right
+ other -> lvl -- to the top
+ | otherwise = lvl
+
maxLvl :: Level -> Level -> Level
maxLvl Top l2 = l2
maxLvl l1 Top = l1
\end{code}
\begin{code}
-type LevelEnv = VarEnv Level
+type LevelEnv = VarEnv (Var, Level)
+ -- We clone let-bound variables so that they are still
+ -- distinct when floated out; hence the Var in the range
+
+extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv
+ -- Used when *not* cloning
+extendLvlEnv env prs = foldl add env prs
+ where
+ add env (v,l) = extendVarEnv env v (v,l)
varLevel :: LevelEnv -> IdOrTyVar -> Level
varLevel env v
= case lookupVarEnv env v of
- Just level -> level
- Nothing -> tOP_LEVEL
+ Just (_,level) -> level
+ Nothing -> tOP_LEVEL
maxIdLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
maxIdLvl env var lvl | isTyVar var = lvl
| otherwise = case lookupVarEnv env var of
- Just lvl' -> maxLvl lvl' lvl
- Nothing -> lvl
+ Just (_,lvl') -> maxLvl lvl' lvl
+ Nothing -> lvl
maxTyVarLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
maxTyVarLvl env var lvl | isId var = lvl
| otherwise = case lookupVarEnv env var of
- Just lvl' -> maxLvl lvl' lvl
- Nothing -> lvl
+ Just (_,lvl') -> maxLvl lvl' lvl
+ Nothing -> lvl
\end{code}
%************************************************************************
-> CoreBindWithFVs
-> LvlM ([LevelledBind], LevelEnv)
-lvlBind ctxt_lvl env (AnnNonRec name rhs)
- = setFloatLevel (Just name) ctxt_lvl env rhs ty `thenLvl` \ (final_lvl, rhs') ->
+lvlBind ctxt_lvl env (AnnNonRec bndr rhs)
+ = setFloatLevel (Just bndr) ctxt_lvl env rhs ty `thenLvl` \ (final_lvl, rhs') ->
+ cloneVar ctxt_lvl bndr `thenLvl` \ new_bndr ->
let
- new_env = extendVarEnv env name final_lvl
+ new_env = extendVarEnv env bndr (new_bndr,final_lvl)
in
- returnLvl ([NonRec (name, final_lvl) rhs'], new_env)
+ returnLvl ([NonRec (new_bndr, final_lvl) rhs'], new_env)
where
- ty = idType name
+ ty = idType bndr
-lvlBind ctxt_lvl env (AnnRec pairs)
- = decideRecFloatLevel ctxt_lvl env binders rhss `thenLvl` \ (final_lvl, extra_binds, rhss') ->
- let
- binders_w_lvls = binders `zip` repeat final_lvl
- new_env = extendVarEnvList env binders_w_lvls
- in
- returnLvl (extra_binds ++ [Rec (zipEqual "lvlBind" binders_w_lvls rhss')], new_env)
- where
- (binders,rhss) = unzip pairs
+lvlBind ctxt_lvl env (AnnRec pairs) = lvlRecBind ctxt_lvl env pairs
\end{code}
%************************************************************************
\begin{code}
lvlExpr _ _ (_, AnnType ty) = returnLvl (Type ty)
-lvlExpr _ _ (_, AnnVar v) = returnLvl (Var v)
+lvlExpr _ env (_, AnnVar v) = case lookupVarEnv env v of
+ Just (v',_) -> returnLvl (Var v')
+ Nothing -> returnLvl (Var v)
lvlExpr ctxt_lvl env (_, AnnCon con args)
= mapLvl (lvlExpr ctxt_lvl env) args `thenLvl` \ args' ->
incd_lvl | bndr_is_id = incMajorLvl ctxt_lvl
| otherwise = incMinorLvl ctxt_lvl
lvld_bndrs = [(b,incd_lvl) | b <- (bndr:bndrs)]
- new_env = extendVarEnvList env lvld_bndrs
+ new_env = extendLvlEnv env lvld_bndrs
go (_, AnnLam bndr rhs) | bndr_is_id && isId bndr
|| bndr_is_tyvar && isTyVar bndr
where
expr_type = coreExprType (deAnnotate expr)
incd_lvl = incMinorLvl ctxt_lvl
- alts_env = extendVarEnv env case_bndr incd_lvl
+ alts_env = extendVarEnv env case_bndr (case_bndr,incd_lvl)
lvl_alt (con, bs, rhs)
= let
bs' = [ (b, incd_lvl) | b <- bs ]
- new_env = extendVarEnvList alts_env bs'
+ new_env = extendLvlEnv alts_env bs'
in
lvlMFE incd_lvl new_env rhs `thenLvl` \ rhs' ->
returnLvl (con, bs', rhs')
| not alreadyLetBound
&& (expr_is_trivial || expr_is_bottom || not will_float_past_lambda)
+
= -- Pin trivial non-let-bound expressions,
-- or ones which aren't going anywhere useful
lvlExpr ctxt_lvl env expr `thenLvl` \ expr' ->
- returnLvl (ctxt_lvl, expr')
+ returnLvl (safe_ctxt_lvl, expr')
{- SDM 7/98
The above case used to read (whnf_or_bottom || not will_float_past_lambda).
= -- Process the expression with a new ctxt_lvl, obtained from
-- the free vars of the expression itself
lvlExpr expr_lvl env expr `thenLvl` \ expr' ->
- returnLvl (expr_lvl, expr')
+ returnLvl (safe_expr_lvl, expr')
| otherwise -- This will create a let anyway, even if there is no
-- type variable to abstract, so we try to abstract anyway
= abstractWrtTyVars offending_tyvars ty env lvl_after_ty_abstr expr
`thenLvl` \ final_expr ->
- returnLvl (expr_lvl, final_expr)
+ returnLvl (safe_expr_lvl, final_expr)
-- OLD LIE: The body of the let, just a type application, isn't worth floating
-- so pin it with ctxt_lvl
-- The truth: better to give it expr_lvl in case it is pinning
where
alreadyLetBound = maybeToBool maybe_let_bound
+ safe_ctxt_lvl = unTopify ty ctxt_lvl
+ safe_expr_lvl = unTopify ty expr_lvl
+
fvs = case maybe_let_bound of
Nothing -> expr_fvs
Just id -> expr_fvs `unionVarSet` idFreeVars id
-- These defns are just like those in the TyLam case of lvlExpr
incd_lvl = incMinorLvl lvl
tyvar_lvls = [(tv,incd_lvl) | tv <- offending_tyvars]
- new_env = extendVarEnvList env tyvar_lvls
+ new_env = extendLvlEnv env tyvar_lvls
\end{code}
Recursive definitions. We want to transform
let D in body
where ab are the tyvars pinning the defn further in than it
-need be, and D is a bunch of simple type applications:
+need be, and D is a bunch of simple type applications:
x1_cl = x1' ab
...
type lambdas.
\begin{code}
-decideRecFloatLevel ctxt_lvl env ids rhss
+lvlRecBind ctxt_lvl env pairs
| ids_only_lvl `ltLvl` tyvars_only_lvl
= -- Abstract wrt tyvars;
-- offending_tyvars is definitely non-empty
-- (I love the ASSERT to check this... WDP 95/02)
let
- incd_lvl = incMinorLvl ids_only_lvl
- tyvars_w_lvl = [(var,incd_lvl) | var <- offending_tyvars]
- ids_w_lvl = [(var,incd_lvl) | var <- ids]
- new_env = extendVarEnvList env (tyvars_w_lvl ++ ids_w_lvl)
+ incd_lvl = incMinorLvl ids_only_lvl
+ tyvars_w_rhs_lvl = [(var,incd_lvl) | var <- offending_tyvars]
+ bndrs_w_rhs_lvl = [(var,incd_lvl) | var <- bndrs]
+ rhs_env = extendLvlEnv env (tyvars_w_rhs_lvl ++ bndrs_w_rhs_lvl)
in
- mapLvl (lvlExpr incd_lvl new_env) rhss `thenLvl` \ rhss' ->
+ mapLvl (lvlExpr incd_lvl rhs_env) rhss `thenLvl` \ rhss' ->
mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars ->
+ mapLvl (cloneVar ctxt_lvl) bndrs `thenLvl` \ new_bndrs ->
let
- ids_w_poly_vars = zipEqual "decideRec2" ids poly_vars
-
-- The "d_rhss" are the right-hand sides of "D" and "D'"
-- in the documentation above
d_rhss = [ mkTyApps (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
-- "local_binds" are "D'" in the documentation above
- local_binds = zipWithEqual "SetLevels" NonRec ids_w_lvl d_rhss
+ local_binds = zipWithEqual "SetLevels" NonRec bndrs_w_rhs_lvl d_rhss
- poly_var_rhss = [ mkLams tyvars_w_lvl (mkLets local_binds rhs')
+ poly_var_rhss = [ mkLams tyvars_w_rhs_lvl (mkLets local_binds rhs')
| rhs' <- rhss'
]
poly_binds = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars]
poly_var_rhss
+ -- The new right-hand sides, just a type application,
+ -- aren't worth floating so pin it with ctxt_lvl
+ bndrs_w_lvl = new_bndrs `zip` repeat ctxt_lvl
+ new_env = extendVarEnvList env (bndrs `zip` bndrs_w_lvl)
+
+ -- "d_binds" are the "D" in the documentation above
+ d_binds = zipWithEqual "SetLevels" NonRec bndrs_w_lvl d_rhss
in
- returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
- -- The new right-hand sides, just a type application, aren't worth floating
- -- so pin it with ctxt_lvl
+ returnLvl (Rec poly_binds : d_binds, new_env)
| otherwise
= -- Let it float freely
+ mapLvl (cloneVar ctxt_lvl) bndrs `thenLvl` \ new_bndrs ->
let
- ids_w_lvls = ids `zip` repeat expr_lvl
- new_env = extendVarEnvList env ids_w_lvls
+ bndrs_w_lvls = new_bndrs `zip` repeat expr_lvl
+ new_env = extendVarEnvList env (bndrs `zip` bndrs_w_lvls)
in
mapLvl (lvlExpr expr_lvl new_env) rhss `thenLvl` \ rhss' ->
- returnLvl (expr_lvl, [], rhss')
+ returnLvl ([Rec (bndrs_w_lvls `zip` rhss')], new_env)
where
+ (bndrs,rhss) = unzip pairs
+
-- Finding the free vars of the binding group is annoying
- bind_fvs = (unionVarSets (map fst rhss) `unionVarSet` unionVarSets (map idFreeVars ids))
+ bind_fvs = (unionVarSets (map fst rhss) `unionVarSet` unionVarSets (map idFreeVars bndrs))
`minusVarSet`
- mkVarSet ids
+ mkVarSet bndrs
ids_only_lvl = foldVarSet (maxIdLvl env) tOP_LEVEL bind_fvs
tyvars_only_lvl = foldVarSet (maxTyVarLvl env) tOP_LEVEL bind_fvs
| otherwise = ids_only_lvl `ltLvl` varLevel env var
offending_tyvar_tys = mkTyVarTys offending_tyvars
- tys = map idType ids
- poly_tys = map (mkForAllTys offending_tyvars) tys
+ tys = map idType bndrs
+ poly_tys = map (mkForAllTys offending_tyvars) tys
\end{code}
%************************************************************************
thenLvl = thenUs
returnLvl = returnUs
mapLvl = mapUs
-mapAndUnzipLvl = mapAndUnzipUs
-mapAndUnzip3Lvl = mapAndUnzip3Us
\end{code}
-We create a let-binding for `interesting' (non-utterly-trivial)
-applications, to give them a fighting chance of being floated.
-
\begin{code}
newLvlVar :: Type -> LvlM Id
newLvlVar ty = getUniqueUs `thenLvl` \ uniq ->
returnUs (mkSysLocal SLIT("lvl") uniq ty)
+
+cloneVar :: Level -> Id -> LvlM Id
+cloneVar Top v = returnUs v -- Don't clone top level things
+cloneVar _ v = getUniqueUs `thenLvl` \ uniq ->
+ returnUs (setVarUnique v uniq)
\end{code}
#include "HsVersions.h"
import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
- SwitchResult, switchIsOn,
- opt_D_dump_occur_anal,
+ SwitchResult(..), switchIsOn, intSwitchSet,
+ opt_D_dump_occur_anal, opt_D_dump_rules,
opt_D_dump_simpl_iterations,
- opt_D_simplifier_stats,
- opt_D_dump_simpl,
+ opt_D_dump_simpl_stats,
+ opt_D_dump_simpl, opt_D_dump_rules,
opt_D_verbose_core2core,
opt_D_dump_occur_anal,
opt_UsageSPOn,
)
import CoreLint ( beginPass, endPass )
+import CoreTidy ( tidyCorePgm )
import CoreSyn
+import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )
+import CoreUnfold
import PprCore ( pprCoreBindings )
import OccurAnal ( occurAnalyseBinds )
import CoreUtils ( exprIsTrivial, coreExprType )
-import Simplify ( simplBind )
-import SimplUtils ( etaCoreExpr, findDefault )
+import Simplify ( simplTopBinds, simplExpr )
+import SimplUtils ( etaCoreExpr, findDefault, simplBinders )
import SimplMonad
-import CoreUnfold
import Const ( Con(..), Literal(..), literalType, mkMachInt )
import ErrUtils ( dumpIfSet )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( Id, mkSysLocal, mkUserId, isBottomingId,
- idType, setIdType, idName, idInfo, idDetails
+import Id ( Id, mkSysLocal, mkVanillaId, isBottomingId,
+ idType, setIdType, idName, idInfo, setIdNoDiscard
)
import IdInfo ( InlinePragInfo(..), specInfo, setSpecInfo,
inlinePragInfo, setInlinePragInfo,
import VarEnv
import VarSet
import Module ( Module )
-import Name ( mkLocalName, tidyOccName, tidyTopName, initTidyOccEnv, isExported,
+import Name ( mkLocalName, tidyOccName, tidyTopName,
NamedThing(..), OccName
)
import TyCon ( TyCon, isDataTyCon )
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
import Specialise ( specProgram)
-import SpecEnv ( specEnvToList, specEnvFromList )
import UsageSPInf ( doUsageSPInf )
import StrictAnal ( saBinds )
import WorkWrap ( wwTopBinds )
import CprAnalyse ( cprAnalyse )
-import Var ( TyVar, mkId )
import Unique ( Unique, Uniquable(..),
- ratioTyConKey, mkUnique, incrUnique, initTidyUniques
+ ratioTyConKey
)
-import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply )
+import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
import Util ( mapAccumL )
import SrcLoc ( noSrcLoc )
import Ratio ( numerator, denominator )
\end{code}
+%************************************************************************
+%* *
+\subsection{The driver for the simplifier}
+%* *
+%************************************************************************
+
\begin{code}
core2core :: [CoreToDo] -- Spec of what core-to-core passes to do
- -> Module -- Module name (profiling only)
- -> [Class] -- Local classes
- -> UniqSupply -- A name supply
- -> [CoreBind] -- Input
- -> IO [CoreBind] -- Result
+ -> [CoreBind] -- Binds in
+ -> [ProtoCoreRule] -- Rules
+ -> IO ([CoreBind], [ProtoCoreRule])
-core2core core_todos module_name classes us binds
+core2core core_todos binds rules
= do
- let (us1, us23) = splitUniqSupply us
- (us2, us3 ) = splitUniqSupply us23
+ us <- mkSplitUniqSupply 's'
+ let (cp_us, us1) = splitUniqSupply us
+ (ru_us, ps_us) = splitUniqSupply us1
+
+ better_rules <- simplRules ru_us rules binds
+
+ let (binds1, rule_base) = prepareRuleBase binds better_rules
-- Do the main business
- processed_binds <- doCorePasses us1 binds core_todos
+ (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1
+ rule_base core_todos
- -- Do the post-simplification business
- post_simpl_binds <- doPostSimplification us2 processed_binds
+ dumpIfSet opt_D_dump_simpl_stats
+ "Grand total simplifier statistics"
+ (pprSimplCount stats)
- -- Do the final tidy-up
- final_binds <- tidyCorePgm us3 module_name classes post_simpl_binds
+ -- Do the post-simplification business
+ post_simpl_binds <- doPostSimplification ps_us processed_binds
-- Return results
- return final_binds
+ return (post_simpl_binds, filter orphanRule better_rules)
+
-doCorePasses us binds []
- = return binds
+doCorePasses stats us binds irs []
+ = return (stats, binds)
-doCorePasses us binds (to_do : to_dos)
+doCorePasses stats us binds irs (to_do : to_dos)
= do
let (us1, us2) = splitUniqSupply us
- binds1 <- doCorePass us1 binds to_do
- doCorePasses us2 binds1 to_dos
-
-doCorePass us binds (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm sw_chkr us binds
-doCorePass us binds CoreLiberateCase = _scc_ "LiberateCase" liberateCase binds
-doCorePass us binds CoreDoFloatInwards = _scc_ "FloatInwards" floatInwards binds
-doCorePass us binds CoreDoFullLaziness = _scc_ "CoreFloating" floatOutwards us binds
-doCorePass us binds CoreDoStaticArgs = _scc_ "CoreStaticArgs" doStaticArgs us binds
-doCorePass us binds CoreDoStrictness = _scc_ "CoreStranal" saBinds binds
-doCorePass us binds CoreDoWorkerWrapper = _scc_ "CoreWorkWrap" wwTopBinds us binds
-doCorePass us binds CoreDoSpecialising = _scc_ "Specialise" specProgram us binds
-doCorePass us binds CoreDoUSPInf
+ (stats1, binds1) <- doCorePass us1 binds irs to_do
+ doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
+
+doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds
+doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds)
+doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds)
+doCorePass us binds rb CoreDoFullLaziness = _scc_ "FloatOutwards" noStats (floatOutwards us binds)
+doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds)
+doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds)
+doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds)
+doCorePass us binds rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds)
+doCorePass us binds rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds)
+doCorePass us binds rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds)
+doCorePass us binds rb CoreDoUSPInf
= _scc_ "CoreUsageSPInf"
if opt_UsageSPOn then
- doUsageSPInf us binds
+ noStats (doUsageSPInf us binds)
else
trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
- return binds
-doCorePass us binds CoreDoCPResult = _scc_ "CPResult" cprAnalyse binds
-doCorePass us binds CoreDoPrintCore
- = _scc_ "PrintCore"
- do
- putStr (showSDoc $ pprCoreBindings binds)
- return binds
+ noStats (return binds)
+
+printCore binds = do dumpIfSet True "Print Core"
+ (pprCoreBindings binds)
+ return binds
+
+noStats thing = do { result <- thing; return (zeroSimplCount, result) }
\end{code}
%************************************************************************
%* *
+\subsection{Dealing with rules}
+%* *
+%************************************************************************
+
+We must do some gentle simplifiation on the template (but not the RHS)
+of each rule. The case that forced me to add this was the fold/build rule,
+which without simplification looked like:
+ fold k z (build (/\a. g a)) ==> ...
+This doesn't match unless you do eta reduction on the build argument.
+
+\begin{code}
+simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
+simplRules us rules binds
+ = do let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
+
+ dumpIfSet opt_D_dump_rules
+ "Transformation rules"
+ (vcat (map pprProtoCoreRule better_rules))
+
+ return better_rules
+ where
+ black_list_all v = True -- This stops all inlining
+ sw_chkr any = SwBool False -- A bit bogus
+
+ -- Boringly, we need to gather the in-scope set.
+ -- Typically this thunk won't even be force, but the test in
+ -- simpVar fails if it isn't right, and it might conceivably matter
+ bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
+
+
+simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
+ | not is_local
+ = returnSmpl rule -- No need to fiddle with imported rules
+ | otherwise
+ = simplBinders bndrs $ \ bndrs' ->
+ mapSmpl simplExpr args `thenSmpl` \ args' ->
+ simplExpr rhs `thenSmpl` \ rhs' ->
+ returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
+\end{code}
+
+%************************************************************************
+%* *
\subsection{The driver for the simplifier}
%* *
%************************************************************************
\begin{code}
-simplifyPgm :: (SimplifierSwitch -> SwitchResult)
+simplifyPgm :: RuleBase
+ -> (SimplifierSwitch -> SwitchResult)
-> UniqSupply
- -> [CoreBind] -- Input
- -> IO [CoreBind] -- New bindings
+ -> [CoreBind] -- Input
+ -> IO (SimplCount, [CoreBind]) -- New bindings
-simplifyPgm sw_chkr us binds
+simplifyPgm (imported_rule_ids, rule_lhs_fvs)
+ sw_chkr us binds
= do {
beginPass "Simplify";
- (termination_msg, it_count, counts, binds') <- iteration us 1 zeroSimplCount binds;
+ -- Glom all binds together in one Rec, in case any
+ -- transformations have introduced any new dependencies
+ let { recd_binds = [Rec (flattenBinds binds)] };
+
+ (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;
- dumpIfSet opt_D_simplifier_stats "Simplifier statistics"
+ dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
+ "Simplifier statistics"
(vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
text "",
- pprSimplCount counts]);
+ pprSimplCount counts_out]);
endPass "Simplify"
(opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
- binds'
+ binds' ;
+
+ return (counts_out, binds')
}
where
- max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
- simpl_switch_is_on = switchIsOn sw_chkr
+ max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
+ black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
| otherwise = empty
iteration us iteration_no counts binds
= do {
-- Occurrence analysis
- let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds simpl_switch_is_on binds };
+ let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
+
dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
-- Simplify
- let { (binds', counts') = initSmpl sw_chkr us1 (simplTopBinds tagged_binds);
+ let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids
+ black_list_fn
+ (simplTopBinds tagged_binds);
all_counts = counts `plusSimplCount` counts'
} ;
dumpIfSet opt_D_dump_simpl_iterations
("Simplifier iteration " ++ show iteration_no
++ " out of " ++ show max_iterations)
- (vcat[pprSimplCount counts',
- text "",
- core_iter_dump binds']) ;
+ (pprSimplCount counts') ;
+
+ if opt_D_dump_simpl_iterations then
+ endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
+ opt_D_verbose_core2core
+ binds'
+ else
+ return [] ;
-- Stop if we've run out of iterations
if iteration_no == max_iterations then
do {
- if max_iterations > 1 then
+ if max_iterations > 2 then
hPutStr stderr ("NOTE: Simplifier still going after " ++
show max_iterations ++
" iterations; bailing out.\n")
} }
where
(us1, us2) = splitUniqSupply us
-
-
-simplTopBinds binds = go binds `thenSmpl` \ (binds', _) ->
- returnSmpl binds'
- where
- go [] = returnSmpl ([], ())
- go (bind1 : binds) = simplBind bind1 (go binds)
\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 -> [Class] -> [CoreBind] -> IO [CoreBind]
-tidyCorePgm us mod local_classes binds_in
- = do
- beginPass "Tidy Core"
- let (_, binds_tidy) = mapAccumL (tidyBind (Just mod)) init_tidy_env binds_in
- 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
- where
- -- Make sure to avoid the names of class operations
- -- They don't have top-level bindings, so we won't see them
- -- in binds_in; so we must initialise the tidy_env appropriately
- --
- -- 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. Name.tidyName then does a no-op on exported binders.
- init_tidy_env = (initTidyOccEnv avoids, emptyVarEnv)
- avoids = [getOccName sel_id | cls <- local_classes,
- sel_id <- classSelIds cls]
- ++
- [getOccName bndr | bind <- binds_in,
- bndr <- bindersOf bind,
- isExported 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') = tidyBndr 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
-
- (bndrs, rhss) = unzip pairs
- (env', bndrs') = mapAccumL (tidyBndr maybe_mod) env bndrs
- rhss' = map (tidyExpr env') rhss
- in
- (env', Rec (zip bndrs' rhss'))
-
-tidyExpr env (Type ty) = Type (tidyType env ty)
-tidyExpr env (Con con args) = Con con (map (tidyExpr env) args)
-tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
-tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
-
-tidyExpr env (Let b e) = Let b' (tidyExpr env' e)
- where
- (env', b') = tidyBind Nothing env b
-
-tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
- where
- (env', b') = tidyNestedBndr env b
-
-tidyExpr env (Var v) = case lookupVarEnv var_env v of
- Just v' -> Var v'
- Nothing -> Var v
- where
- (_, var_env) = env
-
-tidyExpr env (Lam b e) = Lam b' (tidyExpr env' e)
- where
- (env', b') = tidyNestedBndr env b
-
-tidyAlt env (con, vs, rhs) = (con, vs', tidyExpr env' rhs)
- where
- (env', vs') = mapAccumL tidyNestedBndr env vs
-
-tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
-
-tidyNote env note = note
-\end{code}
-
-\begin{code}
-tidyBndr (Just mod) env id = tidyTopBndr mod env id
-tidyBndr Nothing env var = tidyNestedBndr env var
-
-tidyNestedBndr env tyvar
- | isTyVar tyvar
- = tidyTyVar env tyvar
-
-tidyNestedBndr env@(tidy_env, var_env) id
- = -- Non-top-level variables
- let
- -- Give the Id a fresh print-name, *and* rename its type
- -- The SrcLoc isn't important now, though we could extract it from the Id
- name' = mkLocalName (getUnique id) occ' noSrcLoc
- (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
- ty' = tidyType env (idType id)
- id' = mkUserId name' ty'
- -- NB: This throws away the IdInfo of the Id, which we
- -- no longer need. That means we don't need to
- -- run over it with env, nor renumber it.
- var_env' = extendVarEnv var_env id id'
- in
- ((tidy_env', var_env'), id')
-
-tidyTopBndr mod env@(tidy_env, var_env) id
- = -- Top level variables
- let
- (tidy_env', name') = tidyTopName mod tidy_env (idName id)
- ty' = tidyTopType (idType id)
- idinfo' = tidyIdInfo env (idInfo id)
- id' = mkId name' ty' (idDetails id) idinfo'
- var_env' = extendVarEnv var_env id id'
- in
- ((tidy_env', var_env'), id')
-
--- tidyIdInfo does these things:
--- a) tidy the specialisation info (if any)
--- b) zap a complicated ICanSafelyBeINLINEd pragma,
--- c) zap the unfolding
--- The latter two are to avoid space leaks
-
-tidyIdInfo env info
- = info3
- where
- spec_items = specEnvToList (specInfo info)
- spec_env' = specEnvFromList (map tidy_item spec_items)
- info1 | null spec_items = info
- | otherwise = spec_env' `setSpecInfo` info
-
- info2 = case inlinePragInfo info of
- ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo `setInlinePragInfo` info1
- other -> info1
-
- info3 = noUnfolding `setUnfoldingInfo` (wwLazy `setDemandInfo` info2)
-
- tidy_item (tyvars, tys, rhs)
- = (tyvars', tidyTypes env' tys, tidyExpr env' rhs)
- where
- (env', tyvars') = tidyTyVars env tyvars
-\end{code}
-
-
-
-%************************************************************************
-%* *
\subsection{PostSimplification}
%* *
%************************************************************************
-- The continuation type
SimplCont(..), DupFlag(..), contIsDupable, contResultType,
+ contIsInteresting, pushArgs, discardCont, countValArgs, countArgs,
+ contIsInline, discardInlineCont,
-- The monad
SimplM,
initSmpl, returnSmpl, thenSmpl, thenSmpl_,
mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
+ -- The inlining black-list
+ getBlackList,
+
-- Unique supply
getUniqueSmpl, getUniquesSmpl,
newId, newIds,
-- Counting
- SimplCount, TickType(..), TickCounts,
- tick, tickUnfold,
+ SimplCount, Tick(..), TickCounts,
+ tick, freeTick,
getSimplCount, zeroSimplCount, pprSimplCount,
plusSimplCount, isZeroSimplCount,
getEnclosingCC, setEnclosingCC,
-- Environments
- InScopeEnv, SubstEnv,
+ getSubst, setSubst,
+ getSubstEnv, extendSubst, extendSubstList,
getInScope, setInScope, extendInScope, extendInScopes, modifyInScope,
- emptySubstEnv, getSubstEnv, setSubstEnv, zapSubstEnv,
- extendIdSubst, extendTySubst,
- getTyEnv, getValEnv,
+ setSubstEnv, zapSubstEnv,
getSimplBinderStuff, setSimplBinderStuff,
switchOffInlining
) where
#include "HsVersions.h"
+import Const ( Con(DEFAULT) )
import Id ( Id, mkSysLocal, idMustBeINLINEd )
import IdInfo ( InlinePragInfo(..) )
import Demand ( Demand )
import CoreSyn
-import CoreUtils ( IdSubst, SubstCoreExpr, coreExprType, coreAltsType )
+import PprCore () -- Instances
+import Rules ( RuleBase )
import CostCentre ( CostCentreStack, subsumedCCS )
import Var ( TyVar )
import VarEnv
import VarSet
-import Type ( Type, TyVarSubst, funResultTy, fullSubstTy, applyTy )
+import qualified Subst
+import Subst ( Subst, emptySubst, mkSubst,
+ substTy, substEnv,
+ InScopeSet, substInScope, isInScope, lookupInScope
+ )
+import Type ( Type, TyVarSubst, applyTy )
import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
UniqSupply
)
-import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..), intSwitchSet )
+import FiniteMap
+import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..),
+ opt_PprStyle_Debug, opt_HistorySize,
+ intSwitchSet
+ )
import Unique ( Unique )
import Maybes ( expectJust )
import Util ( zipWithEqual )
%************************************************************************
\begin{code}
-type OutExprStuff = OutStuff (InScopeEnv, OutExpr)
+type OutExprStuff = OutStuff (InScopeSet, OutExpr)
type OutStuff a = ([OutBind], a)
-- We return something equivalent to (let b in e), but
-- in pieces to avoid the quadratic blowup when floating
-- incrementally. Comments just before simplExprB in Simplify.lhs
data SimplCont -- Strict contexts
- = Stop
+ = Stop OutType -- Type of the result
- | CoerceIt DupFlag
- InType SubstEnv
+ | CoerceIt OutType -- The To-type, simplified
SimplCont
+ | InlinePlease -- This continuation makes a function very
+ SimplCont -- keen to inline itelf
+
| ApplyTo DupFlag
InExpr SubstEnv -- The argument, as yet unsimplified,
SimplCont -- and its subst-env
InId [InAlt] SubstEnv -- The case binder, alts, and subst-env
SimplCont
- | ArgOf DupFlag -- An arbitrary strict context: the argument
- (OutExpr -> SimplM OutExprStuff) -- of a strict function, or a primitive-arg fn
- -- or a PrimOp
- OutType -- Type of the result of the whole thing
+ | ArgOf DupFlag -- An arbitrary strict context: the argument
+ -- of a strict function, or a primitive-arg fn
+ -- or a PrimOp
+ OutType -- The type of the expression being sought by the context
+ -- f (error "foo") ==> coerce t (error "foo")
+ -- when f is strict
+ -- We need to know the type t, to which to coerce.
+ (OutExpr -> SimplM OutExprStuff) -- What to do with the result
instance Outputable SimplCont where
- ppr Stop = ptext SLIT("Stop")
+ ppr (Stop _) = ptext SLIT("Stop")
ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
- ppr (ArgOf dup cont_fn _) = ptext SLIT("ArgOf...") <+> ppr dup
+ ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup
ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
(nest 4 (ppr alts)) $$ ppr cont
- ppr (CoerceIt dup ty se cont) = (ptext SLIT("CoerceIt") <+> ppr dup <+> ppr ty) $$ ppr cont
+ ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
+ ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
data DupFlag = OkToDup | NoDup
ppr NoDup = ptext SLIT("nodup")
contIsDupable :: SimplCont -> Bool
-contIsDupable Stop = True
+contIsDupable (Stop _) = True
contIsDupable (ApplyTo OkToDup _ _ _) = True
contIsDupable (ArgOf OkToDup _ _) = True
contIsDupable (Select OkToDup _ _ _ _) = True
-contIsDupable (CoerceIt OkToDup _ _ _) = True
+contIsDupable (CoerceIt _ cont) = contIsDupable cont
+contIsDupable (InlinePlease cont) = contIsDupable cont
contIsDupable other = False
-contResultType :: InScopeEnv -> Type -> SimplCont -> Type
-contResultType in_scope e_ty cont
- = go e_ty cont
- where
- go e_ty Stop = e_ty
- go e_ty (ApplyTo _ (Type ty) se cont) = go (applyTy e_ty (simpl se ty)) cont
- go e_ty (ApplyTo _ val_arg _ cont) = go (funResultTy e_ty) cont
- go e_ty (ArgOf _ fun cont_ty) = cont_ty
- go e_ty (CoerceIt _ ty se cont) = go (simpl se ty) cont
- go e_ty (Select _ _ alts se cont) = go (simpl se (coreAltsType alts)) cont
-
- simpl (ty_subst, _) ty = fullSubstTy ty_subst in_scope ty
+contIsInline :: SimplCont -> Bool
+contIsInline (InlinePlease cont) = True
+contIsInline other = False
+
+discardInlineCont :: SimplCont -> SimplCont
+discardInlineCont (InlinePlease cont) = cont
+discardInlineCont cont = cont
+\end{code}
+
+
+Comment about contIsInteresting
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to avoid inlining an expression where there can't possibly be
+any gain, such as in an argument position. Hence, if the continuation
+is interesting (eg. a case scrutinee, application etc.) then we
+inline, otherwise we don't.
+
+Previously some_benefit used to return True only if the variable was
+applied to some value arguments. This didn't work:
+
+ let x = _coerce_ (T Int) Int (I# 3) in
+ case _coerce_ Int (T Int) x of
+ I# y -> ....
+
+we want to inline x, but can't see that it's a constructor in a case
+scrutinee position, and some_benefit is False.
+
+Another example:
+
+dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
+
+.... case dMonadST _@_ x0 of (a,b,c) -> ....
+
+we'd really like to inline dMonadST here, but we *don't* want to
+inline if the case expression is just
+
+ case x of y { DEFAULT -> ... }
+
+since we can just eliminate this case instead (x is in WHNF). Similar
+applies when x is bound to a lambda expression. Hence
+contIsInteresting looks for case expressions with just a single
+default case.
+
+\begin{code}
+contIsInteresting :: SimplCont -> Bool
+contIsInteresting (Select _ _ alts _ _) = not (just_default alts)
+contIsInteresting (CoerceIt _ cont) = contIsInteresting cont
+contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
+contIsInteresting (ApplyTo _ _ _ _) = True
+contIsInteresting (ArgOf _ _ _) = True
+ -- If this call is the arg of a strict function, the context
+ -- is a bit interesting. If we inline here, we may get useful
+ -- evaluation information to avoid repeated evals: e.g.
+ -- x + (y * z)
+ -- Here the contIsInteresting makes the '*' keener to inline,
+ -- which in turn exposes a constructor which makes the '+' inline.
+ -- Assuming that +,* aren't small enough to inline regardless.
+contIsInteresting (InlinePlease _) = True
+contIsInteresting other = False
+
+just_default [(DEFAULT,_,_)] = True -- See notes below for why we look
+just_default alts = False -- for this special case
+\end{code}
+
+
+\begin{code}
+pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont
+pushArgs se [] cont = cont
+pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont)
+
+discardCont :: SimplCont -- A continuation, expecting
+ -> SimplCont -- Replace the continuation with a suitable coerce
+discardCont (Stop to_ty) = Stop to_ty
+discardCont cont = CoerceIt to_ty (Stop to_ty)
+ where
+ to_ty = contResultType cont
+
+contResultType :: SimplCont -> OutType
+contResultType (Stop to_ty) = to_ty
+contResultType (ArgOf _ to_ty _) = to_ty
+contResultType (ApplyTo _ _ _ cont) = contResultType cont
+contResultType (CoerceIt _ cont) = contResultType cont
+contResultType (InlinePlease cont) = contResultType cont
+contResultType (Select _ _ _ _ cont) = contResultType cont
+
+countValArgs :: SimplCont -> Int
+countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
+countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
+countValArgs other = 0
+
+countArgs :: SimplCont -> Int
+countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
+countArgs other = 0
\end{code}
data SimplEnv
= SimplEnv {
- seChkr :: SwitchChecker,
- seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
- seSubst :: SubstEnv, -- The current substitution
- seInScope :: InScopeEnv -- Says what's in scope and gives info about it
+ seChkr :: SwitchChecker,
+ seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
+ seBlackList :: Id -> Bool, -- True => don't inline this Id
+ seSubst :: Subst -- The current substitution
}
+ -- The range of the substitution is OutType and OutExpr resp
+ --
+ -- The substitution is idempotent
+ -- It *must* be applied; things in its domain simply aren't
+ -- bound in the result.
+ --
+ -- The substitution usually maps an Id to its clone,
+ -- but if the orig defn is a let-binding, and
+ -- the RHS of the let simplifies to an atom,
+ -- we just add the binding to the substitution and elide the let.
+
+ -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
+ -- The elements of the set may have better IdInfo than the
+ -- occurrences of in-scope Ids, and (more important) they will
+ -- have a correctly-substituted type. So we use a lookup in this
+ -- set to replace occurrences
\end{code}
\begin{code}
initSmpl :: SwitchChecker
-> UniqSupply -- No init count; set to 0
+ -> VarSet -- In scope (usually empty, but useful for nested calls)
+ -> (Id -> Bool) -- Black-list function
-> SimplM a
-> (a, SimplCount)
-initSmpl chkr us m = case m (emptySimplEnv chkr) us zeroSimplCount of
- (result, _, count) -> (result, count)
+initSmpl chkr us in_scope black_list m
+ = case m (emptySimplEnv chkr in_scope black_list) us zeroSimplCount of
+ (result, _, count) -> (result, count)
{-# INLINE thenSmpl #-}
%************************************************************************
\begin{code}
-doTickSmpl :: (SimplCount -> SimplCount) -> SimplM ()
-doTickSmpl f env us sc = sc' `seq` ((), us, sc')
- where
- sc' = f sc
-
getSimplCount :: SimplM SimplCount
getSimplCount env us sc = (sc, us, sc)
-\end{code}
-
-The assoc list isn't particularly costly, because we only use
-the number of ticks in ``real life.''
+tick :: Tick -> SimplM ()
+tick t env us sc = sc' `seq` ((), us, sc')
+ where
+ sc' = doTick t sc
+
+freeTick :: Tick -> SimplM ()
+-- Record a tick, but don't add to the total tick count, which is
+-- used to decide when nothing further has happened
+freeTick t env us sc = sc' `seq` ((), us, sc')
+ where
+ sc' = doFreeTick t sc
+\end{code}
-The right thing to do, if you want that to go fast, is thread
-a mutable array through @SimplM@.
+\begin{code}
+verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
+
+-- Defined both with and without debugging
+zeroSimplCount :: SimplCount
+isZeroSimplCount :: SimplCount -> Bool
+pprSimplCount :: SimplCount -> SDoc
+doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
+plusSimplCount :: SimplCount -> SimplCount -> SimplCount
+\end{code}
\begin{code}
-data SimplCount
- = SimplCount !TickCounts
- !UnfoldingHistory
-
-type TickCounts = [(TickType, Int)] -- Assoc list of all diff kinds of ticks
- -- Kept in increasing order of TickType
- -- Zeros not present
-
-type UnfoldingHistory = (Int, -- N
- [Id], -- Last N unfoldings
- [Id]) -- The MaxUnfoldHistory unfoldings before that
-
-data TickType
- = PreInlineUnconditionally
- | PostInlineUnconditionally
- | UnfoldingDone
- | MagicUnfold
- | CaseOfCase
- | LetFloatFromLet
- | KnownBranch
- | Let2Case
- | Case2Let
- | CaseMerge
- | CaseElim
- | CaseIdentity
- | EtaExpansion
- | CaseOfError
- | BetaReduction
- | SpecialisationDone
- | FillInCaseDefault
- | LeavesExamined
- deriving (Eq, Ord, Show)
-
-pprSimplCount :: SimplCount -> SDoc
-pprSimplCount (SimplCount stuff (_, unf1, unf2))
- = vcat (map ppr_item stuff)
- $$ (text "Most recent unfoldings (most recent at top):"
- $$ nest 4 (vcat (map ppr (unf1 ++ unf2))))
- where
- ppr_item (t,n) = text (show t) <+> char '\t' <+> ppr n
+#ifndef DEBUG
+----------------------------------------------------------
+-- Debugging OFF
+----------------------------------------------------------
+type SimplCount = Int
zeroSimplCount :: SimplCount
-zeroSimplCount = SimplCount [] (0, [], [])
-
-isZeroSimplCount :: SimplCount -> Bool
-isZeroSimplCount (SimplCount [] _) = True
-isZeroSimplCount (SimplCount [(LeavesExamined,_)] _) = True
-isZeroSimplCount other = False
-
--- incTick is careful to be pretty strict, so we don't
--- get a huge buildup of thunks
-incTick :: TickType -> FAST_INT -> TickCounts -> TickCounts
-incTick tick_type n []
- = [(tick_type, IBOX(n))]
-
-incTick tick_type n (x@(ttype, I# cnt#) : xs)
- = case tick_type `compare` ttype of
- LT -> -- Insert here
- (tick_type, IBOX(n)) : x : xs
-
- EQ -> -- Increment
- case cnt# +# n of
- incd -> (ttype, IBOX(incd)) : xs
-
- GT -> -- Move on
- rest `seq` x : rest
- where
- rest = incTick tick_type n xs
-
--- Second argument is more recent stuff
-plusSimplCount :: SimplCount -> SimplCount -> SimplCount
-plusSimplCount (SimplCount tc1 uh1) (SimplCount tc2 uh2)
- = SimplCount (plusTickCounts tc1 tc2) (plusUnfolds uh1 uh2)
-
-plusTickCounts :: TickCounts -> TickCounts -> TickCounts
-plusTickCounts ts1 [] = ts1
-plusTickCounts [] ts2 = ts2
-plusTickCounts ((tt1,n1) : ts1) ((tt2,n2) : ts2)
- = case tt1 `compare` tt2 of
- LT -> (tt1,n1) : plusTickCounts ts1 ((tt2,n2) : ts2)
- EQ -> (tt1,n1+n2) : plusTickCounts ts1 ts2
- GT -> (tt2,n2) : plusTickCounts ((tt1,n1) : ts1) ts2
-
--- Second argument is the more recent stuff
-plusUnfolds uh1 (0, h2, t2) = uh1 -- Nothing recent
-plusUnfolds (n1, h1, t1) (n2, h2, []) = (n2, h2, (h1++t1)) -- Small amount recent
-plusUnfolds (n1, h1, t1) uh2 = uh2 -- Decent batch recent
-\end{code}
+zeroSimplCount = 0
+isZeroSimplCount n = n==0
-Counting-related monad functions:
+doTick t n = n+1 -- Very basic when not debugging
+doFreeTick t n = n -- Don't count leaf visits
-\begin{code}
-tick :: TickType -> SimplM ()
+pprSimplCount n = ptext SLIT("Total ticks:") <+> int n
+
+plusSimplCount n m = n+m
+
+#else
+----------------------------------------------------------
+-- Debugging ON
+----------------------------------------------------------
+
+data SimplCount = SimplCount {
+ ticks :: !Int, -- Total ticks
+ details :: !TickCounts, -- How many of each type
+ n_log :: !Int, -- N
+ log1 :: [Tick], -- Last N events; <= opt_HistorySize
+ log2 :: [Tick] -- Last opt_HistorySize events before that
+ }
-tick tick_type
- = doTickSmpl f
+type TickCounts = FiniteMap Tick Int
+
+zeroSimplCount = SimplCount {ticks = 0, details = emptyFM,
+ n_log = 0, log1 = [], log2 = []}
+
+isZeroSimplCount sc = ticks sc == 0
+
+doFreeTick tick sc@SimplCount { details = dts }
+ = dts' `seqFM` sc { details = dts' }
+ where
+ dts' = dts `addTick` tick
+
+-- Gross hack to persuade GHC 3.03 to do this important seq
+seqFM fm x | isEmptyFM fm = x
+ | otherwise = x
+
+doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
+ | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
+ | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
+ where
+ sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
+
+-- Don't use plusFM_C because that's lazy, and we want to
+-- be pretty strict here!
+addTick :: TickCounts -> Tick -> TickCounts
+addTick fm tick = case lookupFM fm tick of
+ Nothing -> addToFM fm tick 1
+ Just n -> n1 `seq` addToFM fm tick n1
+ where
+ n1 = n+1
+
+plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
+ sc2@(SimplCount { ticks = tks2, details = dts2 })
+ = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
where
- f (SimplCount stuff unf) = SimplCount (incTick tick_type ILIT(1) stuff) unf
-
-maxUnfoldHistory :: Int
-maxUnfoldHistory = 20
-
-tickUnfold :: Id -> SimplM ()
-tickUnfold id
- = doTickSmpl f
- where
- f (SimplCount stuff (n_unf, unf1, unf2))
- | n_unf >= maxUnfoldHistory = SimplCount new_stuff (1, [id], unf1)
- | otherwise = SimplCount new_stuff (n_unf+1, id:unf1, unf2)
- where
- new_stuff = incTick UnfoldingDone ILIT(1) stuff
+ -- A hackish way of getting recent log info
+ log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
+ | null (log2 sc2) = sc2 { log2 = log1 sc1 }
+ | otherwise = sc2
+
+
+pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
+ = vcat [ptext SLIT("Total ticks: ") <+> int tks,
+ text "",
+ pprTickCounts (fmToList dts),
+ if verboseSimplStats then
+ vcat [text "",
+ ptext SLIT("Log (most recent first)"),
+ nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
+ else empty
+ ]
+
+pprTickCounts :: [(Tick,Int)] -> SDoc
+pprTickCounts [] = empty
+pprTickCounts ((tick1,n1):ticks)
+ = vcat [int tot_n <+> text (tickString tick1),
+ pprTCDetails real_these,
+ pprTickCounts others
+ ]
+ where
+ tick1_tag = tickToTag tick1
+ (these, others) = span same_tick ticks
+ real_these = (tick1,n1):these
+ same_tick (tick2,_) = tickToTag tick2 == tick1_tag
+ tot_n = sum [n | (_,n) <- real_these]
+
+pprTCDetails ticks@((tick,_):_)
+ | verboseSimplStats || isRuleFired tick
+ = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
+ | otherwise
+ = empty
+#endif
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Ticks}
+%* *
+%************************************************************************
+
+\begin{code}
+data Tick
+ = PreInlineUnconditionally Id
+ | PostInlineUnconditionally Id
+
+ | UnfoldingDone Id
+ | RuleFired FAST_STRING -- Rule name
+
+ | LetFloatFromLet Id -- Thing floated out
+ | EtaExpansion Id -- LHS binder
+ | EtaReduction Id -- Binder on outer lambda
+ | BetaReduction Id -- Lambda binder
+
+
+ | CaseOfCase Id -- Bndr on *inner* case
+ | KnownBranch Id -- Case binder
+ | CaseMerge Id -- Binder on outer case
+ | CaseElim Id -- Case binder
+ | CaseIdentity Id -- Case binder
+ | FillInCaseDefault Id -- Case binder
+
+ | BottomFound
+ | LeafVisit
+ | SimplifierDone -- Ticked at each iteration of the simplifier
+
+isRuleFired (RuleFired _) = True
+isRuleFired other = False
+
+instance Outputable Tick where
+ ppr tick = text (tickString tick) <+> pprTickCts tick
+
+instance Eq Tick where
+ a == b = case a `cmpTick` b of { EQ -> True; other -> False }
+
+instance Ord Tick where
+ compare = cmpTick
+
+tickToTag :: Tick -> Int
+tickToTag (PreInlineUnconditionally _) = 0
+tickToTag (PostInlineUnconditionally _) = 1
+tickToTag (UnfoldingDone _) = 2
+tickToTag (RuleFired _) = 3
+tickToTag (LetFloatFromLet _) = 4
+tickToTag (EtaExpansion _) = 5
+tickToTag (EtaReduction _) = 6
+tickToTag (BetaReduction _) = 7
+tickToTag (CaseOfCase _) = 8
+tickToTag (KnownBranch _) = 9
+tickToTag (CaseMerge _) = 10
+tickToTag (CaseElim _) = 11
+tickToTag (CaseIdentity _) = 12
+tickToTag (FillInCaseDefault _) = 13
+tickToTag BottomFound = 14
+tickToTag LeafVisit = 15
+tickToTag SimplifierDone = 16
+
+tickString :: Tick -> String
+tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
+tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
+tickString (UnfoldingDone _) = "UnfoldingDone"
+tickString (RuleFired _) = "RuleFired"
+tickString (LetFloatFromLet _) = "LetFloatFromLet"
+tickString (EtaExpansion _) = "EtaExpansion"
+tickString (EtaReduction _) = "EtaReduction"
+tickString (BetaReduction _) = "BetaReduction"
+tickString (CaseOfCase _) = "CaseOfCase"
+tickString (KnownBranch _) = "KnownBranch"
+tickString (CaseMerge _) = "CaseMerge"
+tickString (CaseElim _) = "CaseElim"
+tickString (CaseIdentity _) = "CaseIdentity"
+tickString (FillInCaseDefault _) = "FillInCaseDefault"
+tickString BottomFound = "BottomFound"
+tickString SimplifierDone = "SimplifierDone"
+tickString LeafVisit = "LeafVisit"
+
+pprTickCts :: Tick -> SDoc
+pprTickCts (PreInlineUnconditionally v) = ppr v
+pprTickCts (PostInlineUnconditionally v)= ppr v
+pprTickCts (UnfoldingDone v) = ppr v
+pprTickCts (RuleFired v) = ppr v
+pprTickCts (LetFloatFromLet v) = ppr v
+pprTickCts (EtaExpansion v) = ppr v
+pprTickCts (EtaReduction v) = ppr v
+pprTickCts (BetaReduction v) = ppr v
+pprTickCts (CaseOfCase v) = ppr v
+pprTickCts (KnownBranch v) = ppr v
+pprTickCts (CaseMerge v) = ppr v
+pprTickCts (CaseElim v) = ppr v
+pprTickCts (CaseIdentity v) = ppr v
+pprTickCts (FillInCaseDefault v) = ppr v
+pprTickCts other = empty
+
+cmpTick :: Tick -> Tick -> Ordering
+cmpTick a b = case (tickToTag a `compare` tickToTag b) of
+ GT -> GT
+ EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
+ | otherwise -> EQ
+ LT -> LT
+ -- Always distinguish RuleFired, so that the stats
+ -- can report them even in non-verbose mode
+
+cmpEqTick :: Tick -> Tick -> Ordering
+cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
+cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
+cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
+cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
+cmpEqTick (LetFloatFromLet a) (LetFloatFromLet b) = a `compare` b
+cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
+cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
+cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
+cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
+cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
+cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
+cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
+cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
+cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
+cmpEqTick other1 other2 = EQ
\end{code}
\begin{code}
switchOffInlining :: SimplM a -> SimplM a
-switchOffInlining m env@(SimplEnv { seChkr = sw_chkr }) us sc
- = m (env { seChkr = new_chkr }) us sc
- where
- new_chkr EssentialUnfoldingsOnly = SwBool True
- new_chkr other = sw_chkr other
+switchOffInlining m env us sc
+ = m (env { seBlackList = \v -> True }) us sc
\end{code}
%* *
%************************************************************************
-\begin{code}
-type SubstEnv = (TyVarSubst, IdSubst)
- -- The range of these substitutions is OutType and OutExpr resp
- --
- -- The substitution is idempotent
- -- It *must* be applied; things in its domain simply aren't
- -- bound in the result.
- --
- -- The substitution usually maps an Id to its clone,
- -- but if the orig defn is a let-binding, and
- -- the RHS of the let simplifies to an atom,
- -- we just add the binding to the substitution and elide the let.
-
-type InScopeEnv = IdOrTyVarSet
- -- Domain includes *all* in-scope TyVars and Ids
- --
- -- The elements of the set may have better IdInfo than the
- -- occurrences of in-scope Ids, and (more important) they will
- -- have a correctly-substituted type. So we use a lookup in this
- -- set to replace occurrences
-
--- INVARIANT: If t is in the in-scope set, it certainly won't be
--- in the domain of the SubstEnv, and vice versa
-\end{code}
-
\begin{code}
-emptySubstEnv :: SubstEnv
-emptySubstEnv = (emptyVarEnv, emptyVarEnv)
-
-emptySimplEnv :: SwitchChecker -> SimplEnv
+emptySimplEnv :: SwitchChecker -> InScopeSet -> (Id -> Bool) -> SimplEnv
-emptySimplEnv sw_chkr
+emptySimplEnv sw_chkr in_scope black_list
= SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
- seSubst = emptySubstEnv,
- seInScope = emptyVarSet }
-
+ seBlackList = black_list,
+ seSubst = mkSubst in_scope emptySubstEnv }
-- The top level "enclosing CC" is "SUBSUMED".
-getTyEnv :: SimplM (TyVarSubst, InScopeEnv)
-getTyEnv (SimplEnv {seSubst = (ty_subst,_), seInScope = in_scope}) us sc
- = ((ty_subst, in_scope), us, sc)
+getSubst :: SimplM Subst
+getSubst env us sc = (seSubst env, us, sc)
-getValEnv :: SimplM (IdSubst, InScopeEnv)
-getValEnv (SimplEnv {seSubst = (_, id_subst), seInScope = in_scope}) us sc
- = ((id_subst, in_scope), us, sc)
+getBlackList :: SimplM (Id -> Bool)
+getBlackList env us sc = (seBlackList env, us, sc)
-getInScope :: SimplM InScopeEnv
-getInScope env us sc = (seInScope env, us, sc)
+setSubst :: Subst -> SimplM a -> SimplM a
+setSubst subst m env us sc = m (env {seSubst = subst}) us sc
-setInScope :: InScopeEnv -> SimplM a -> SimplM a
-setInScope in_scope m env us sc = m (env {seInScope = in_scope}) us sc
+getSubstEnv :: SimplM SubstEnv
+getSubstEnv env us sc = (substEnv (seSubst env), us, sc)
extendInScope :: CoreBndr -> SimplM a -> SimplM a
-extendInScope v m env@(SimplEnv {seInScope = in_scope}) us sc
- = m (env {seInScope = extendVarSet in_scope v}) us sc
+extendInScope v m env@(SimplEnv {seSubst = subst}) us sc
+ = m (env {seSubst = Subst.extendInScope subst v}) us sc
extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a
-extendInScopes vs m env@(SimplEnv {seInScope = in_scope}) us sc
- = m (env {seInScope = foldl extendVarSet in_scope vs}) us sc
+extendInScopes vs m env@(SimplEnv {seSubst = subst}) us sc
+ = m (env {seSubst = Subst.extendInScopes subst vs}) us sc
+
+getInScope :: SimplM InScopeSet
+getInScope env us sc = (substInScope (seSubst env), us, sc)
+
+setInScope :: InScopeSet -> SimplM a -> SimplM a
+setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc
+ = m (env {seSubst = Subst.setInScope subst in_scope}) us sc
modifyInScope :: CoreBndr -> SimplM a -> SimplM a
modifyInScope v m env us sc
#ifdef DEBUG
- | not (v `elemVarSet` seInScope env )
+ | not (v `isInScope` seSubst env)
= pprTrace "modifyInScope: not in scope:" (ppr v)
m env us sc
#endif
| otherwise
= extendInScope v m env us sc
-getSubstEnv :: SimplM SubstEnv
-getSubstEnv env us sc = (seSubst env, us, sc)
-
-setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
-setSubstEnv subst_env m env us sc = m (env {seSubst = subst_env}) us sc
+extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
+extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc
+ = m (env { seSubst = Subst.extendSubst subst var res }) us sc
-extendIdSubst :: Id -> SubstCoreExpr -> SimplM a -> SimplM a
-extendIdSubst id expr m env@(SimplEnv {seSubst = (ty_subst, id_subst)}) us sc
- = m (env { seSubst = (ty_subst, extendVarEnv id_subst id expr) }) us sc
+extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
+extendSubstList vars ress m env@(SimplEnv {seSubst = subst}) us sc
+ = m (env { seSubst = Subst.extendSubstList subst vars ress }) us sc
-extendTySubst :: TyVar -> OutType -> SimplM a -> SimplM a
-extendTySubst tv ty m env@(SimplEnv {seSubst = (ty_subst, id_subst)}) us sc
- = m (env { seSubst = (extendVarEnv ty_subst tv ty, id_subst) }) us sc
+setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
+setSubstEnv senv m env@(SimplEnv {seSubst = subst}) us sc
+ = m (env {seSubst = Subst.setSubstEnv subst senv}) us sc
zapSubstEnv :: SimplM a -> SimplM a
-zapSubstEnv m env us sc = m (env {seSubst = emptySubstEnv}) us sc
+zapSubstEnv m env@(SimplEnv {seSubst = subst}) us sc
+ = m (env {seSubst = Subst.zapSubstEnv subst}) us sc
-getSimplBinderStuff :: SimplM (TyVarSubst, IdSubst, InScopeEnv, UniqSupply)
-getSimplBinderStuff (SimplEnv {seSubst = (ty_subst, id_subst), seInScope = in_scope}) us sc
- = ((ty_subst, id_subst, in_scope, us), us, sc)
+getSimplBinderStuff :: SimplM (Subst, UniqSupply)
+getSimplBinderStuff (SimplEnv {seSubst = subst}) us sc
+ = ((subst, us), us, sc)
-setSimplBinderStuff :: (TyVarSubst, IdSubst, InScopeEnv, UniqSupply)
- -> SimplM a -> SimplM a
-setSimplBinderStuff (ty_subst, id_subst, in_scope, us) m env _ sc
- = m (env {seSubst = (ty_subst, id_subst), seInScope = in_scope}) us sc
+setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
+setSimplBinderStuff (subst, us) m env _ sc
+ = m (env {seSubst = subst}) us sc
\end{code}
\begin{code}
newId :: Type -> (Id -> SimplM a) -> SimplM a
-- Extends the in-scope-env too
-newId ty m env@(SimplEnv {seInScope = in_scope}) us sc
+newId ty m env@(SimplEnv {seSubst = subst}) us sc
= case splitUniqSupply us of
- (us1, us2) -> m v (env {seInScope = extendVarSet in_scope v}) us2 sc
+ (us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc
where
v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty
newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
-newIds tys m env@(SimplEnv {seInScope = in_scope}) us sc
+newIds tys m env@(SimplEnv {seSubst = subst}) us sc
= case splitUniqSupply us of
- (us1, us2) -> m vs (env {seInScope = foldl extendVarSet in_scope vs}) us2 sc
+ (us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc
where
vs = zipWithEqual "newIds" (mkSysLocal SLIT("s"))
(uniqsFromSupply (length tys) us1) tys
-\end{code}
+\end{code}
\begin{code}
module SimplUtils (
simplBinder, simplBinders, simplIds,
- mkRhsTyLam,
+ transformRhs,
etaCoreExpr,
- etaExpandCount,
- mkCase, findAlt, findDefault
+ mkCase, findAlt, findDefault,
+ mkCoerce
) where
#include "HsVersions.h"
import BinderInfo
-import CmdLineOpts ( opt_DoEtaReduction, switchIsOn, SimplifierSwitch(..) )
+import CmdLineOpts ( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge )
import CoreSyn
-import CoreUtils ( exprIsCheap, exprIsTrivial, exprFreeVars, cheapEqExpr,
- FormSummary(..),
- substId, substIds
+import CoreFVs ( exprFreeVars )
+import CoreUtils ( exprIsCheap, exprIsTrivial, cheapEqExpr, coreExprType,
+ exprIsWHNF, FormSummary(..)
)
+import Subst ( substBndrs, substBndr, substIds )
import Id ( Id, idType, getIdArity, isId, idName,
getInlinePragma, setInlinePragma,
- getIdDemandInfo
+ getIdDemandInfo, mkId
)
-import IdInfo ( arityLowerBound, InlinePragInfo(..) )
-import Maybes ( maybeToBool )
+import IdInfo ( arityLowerBound, InlinePragInfo(..), setInlinePragInfo, vanillaIdInfo )
+import Maybes ( maybeToBool, catMaybes )
import Const ( Con(..) )
-import Name ( isLocalName )
+import Name ( isLocalName, setNameUnique )
import SimplMonad
import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys,
- splitTyConApp_maybe, substTyVar, mkTyVarTys
+ splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
)
+import TysPrim ( statePrimTyCon )
import Var ( setVarUnique )
import VarSet
import UniqSupply ( splitUniqSupply, uniqFromSupply )
%* *
%************************************************************************
-When we hit a binder we may need to
- (a) apply the the type envt (if non-empty) to its type
- (b) apply the type envt and id envt to its SpecEnv (if it has one)
- (c) give it a new unique to avoid name clashes
-
\begin{code}
simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
simplBinders bndrs thing_inside
- = getSwitchChecker `thenSmpl` \ sw_chkr ->
- getSimplBinderStuff `thenSmpl` \ stuff ->
+ = getSubst `thenSmpl` \ subst ->
let
- must_clone = switchIsOn sw_chkr SimplPleaseClone
- (stuff', bndrs') = mapAccumL (subst_binder must_clone) stuff bndrs
+ (subst', bndrs') = substBndrs subst bndrs
in
- setSimplBinderStuff stuff' $
+ setSubst subst' $
thing_inside bndrs'
simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
simplBinder bndr thing_inside
- = getSwitchChecker `thenSmpl` \ sw_chkr ->
- getSimplBinderStuff `thenSmpl` \ stuff ->
+ = getSubst `thenSmpl` \ subst ->
let
- must_clone = switchIsOn sw_chkr SimplPleaseClone
- (stuff', bndr') = subst_binder must_clone stuff bndr
+ (subst', bndr') = substBndr subst bndr
in
- setSimplBinderStuff stuff' $
+ setSubst subst' $
thing_inside bndr'
+
-- Same semantics as simplBinders, but a little less
-- plumbing and hence a little more efficient.
-- Maybe not worth the candle?
simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
simplIds ids thing_inside
- = getSwitchChecker `thenSmpl` \ sw_chkr ->
- getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) ->
+ = getSubst `thenSmpl` \ subst ->
let
- must_clone = switchIsOn sw_chkr SimplPleaseClone
- (id_subst', in_scope', us', ids') = substIds (simpl_clone_fn must_clone)
- ty_subst id_subst in_scope us ids
+ (subst', bndrs') = substIds subst ids
in
- setSimplBinderStuff (ty_subst, id_subst', in_scope', us') $
- thing_inside ids'
+ setSubst subst' $
+ thing_inside bndrs'
+\end{code}
-subst_binder must_clone (ty_subst, id_subst, in_scope, us) bndr
- | isTyVar bndr
- = case substTyVar ty_subst in_scope bndr of
- (ty_subst', in_scope', bndr') -> ((ty_subst', id_subst, in_scope', us), bndr')
- | otherwise
- = case substId (simpl_clone_fn must_clone) ty_subst id_subst in_scope us bndr of
- (id_subst', in_scope', us', bndr')
- -> ((ty_subst, id_subst', in_scope', us'), bndr')
-
-simpl_clone_fn must_clone in_scope us id
- | (must_clone && isLocalName (idName id))
- || id `elemVarSet` in_scope
- = case splitUniqSupply us of
- (us1, us2) -> Just (us1, setVarUnique id (uniqFromSupply us2))
-
- | otherwise
- = Nothing
+%************************************************************************
+%* *
+\subsection{Transform a RHS}
+%* *
+%************************************************************************
+
+Try (a) eta expansion
+ (b) type-lambda swizzling
+
+\begin{code}
+transformRhs :: InExpr -> SimplM InExpr
+transformRhs rhs
+ = tryEtaExpansion body `thenSmpl` \ body' ->
+ mkRhsTyLam tyvars body'
+ where
+ (tyvars, body) = collectTyBinders rhs
\end{code}
where
G = F . Let {xi = xi' tvs}
-\begin{code}
-mkRhsTyLam (Lam b e)
- | isTyVar b = case collectTyBinders e of
- (bs,body) -> mkRhsTyLam_help (b:bs) body
+[May 1999] If we do this transformation *regardless* then we can
+end up with some pretty silly stuff. For example,
-mkRhsTyLam other_expr -- No-op if not a type lambda
- = returnSmpl other_expr
+ let
+ st = /\ s -> let { x1=r1 ; x2=r2 } in ...
+ in ..
+becomes
+ let y1 = /\s -> r1
+ y2 = /\s -> r2
+ st = /\s -> ...[y1 s/x1, y2 s/x2]
+ in ..
+Unless the "..." is a WHNF there is really no point in doing this.
+Indeed it can make things worse. Suppose x1 is used strictly,
+and is of the form
-mkRhsTyLam_help tyvars body
+ x1* = case f y of { (a,b) -> e }
+
+If we abstract this wrt the tyvar we then can't do the case inline
+as we would normally do.
+
+
+\begin{code}
+mkRhsTyLam tyvars body -- Only does something if there's a let
+ | null tyvars || not (worth_it body) -- inside a type lambda, and a WHNF inside that
+ = returnSmpl (mkLams tyvars body)
+ | otherwise
= go (\x -> x) body
where
+ worth_it (Let _ e) = whnf_in_middle e
+ worth_it other = False
+ whnf_in_middle (Let _ e) = whnf_in_middle e
+ whnf_in_middle e = exprIsWHNF e
+
main_tyvar_set = mkVarSet tyvars
go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
-- /\ a b -> let t :: (a,b) = (e1, e2)
-- x :: a = fst t
-- in ...
- -- Here, b isn't free in a's type, but we must nevertheless
+ -- Here, b isn't free in x's type, but we must nevertheless
-- abstract wrt b as well, because t's type mentions b.
-- Since t is floated too, we'd end up with the bogus:
-- poly_t = /\ a b -> (e1, e2)
go fn body = returnSmpl (mkLams tyvars (fn body))
mk_poly tyvars_here var
- = newId (mkForAllTys tyvars_here (idType var)) $ \ poly_id ->
+ = getUniqueSmpl `thenSmpl` \ uniq ->
let
+ poly_name = setNameUnique (idName var) uniq -- Keep same name
+ poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course
+
-- It's crucial to copy the inline-prag of the original var, because
-- we're looking at occurrence-analysed but as yet unsimplified code!
-- In particular, we mustn't lose the loop breakers.
--
- -- *However* we don't want to retain a single-occurrence or dead-var info
- -- because we're adding a load of "silly bindings" of the form
- -- var _U_ = poly_var t1 t2
- -- with a must-inline pragma on the silly binding to prevent the
- -- poly-var from being inlined right back in. Since poly_var now
- -- occurs inside an INLINE binding, it should be given a ManyOcc,
- -- else it may get inlined unconditionally
- poly_inline_prag = case getInlinePragma var of
- ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo
- IAmDead -> NoInlinePragInfo
- var_inline_prag -> var_inline_prag
-
- poly_id' = setInlinePragma poly_id poly_inline_prag
+ -- It's even right to retain single-occurrence or dead-var info:
+ -- Suppose we started with /\a -> let x = E in B
+ -- where x occurs once in E. Then we transform to:
+ -- let x' = /\a -> E in /\a -> let x* = x' a in B
+ -- where x* has an INLINE prag on it. Now, once x* is inlined,
+ -- the occurrences of x' will be just the occurrences originaly
+ -- pinned on x.
+ poly_info = vanillaIdInfo `setInlinePragInfo` getInlinePragma var
+
+ poly_id = mkId poly_name poly_ty poly_info
in
- returnSmpl (poly_id', mkTyApps (Var poly_id') (mkTyVarTys tyvars_here))
+ returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
- mk_silly_bind var rhs = NonRec (setInlinePragma var IWantToBeINLINEd) rhs
+ mk_silly_bind var rhs = NonRec (setInlinePragma var IMustBeINLINEd) rhs
-- The addInlinePragma is really important! If we don't say
-- INLINE on these silly little bindings then look what happens!
-- Suppose we start with:
-- * but then it gets inlined into the rhs of g*
-- * then the binding for g* is floated out of the /\b
-- * so we're back to square one
- -- The silly binding for g* must be INLINE, so that no inlining
- -- will happen in its RHS.
- -- PS: Jun 98: actually this isn't important any more;
- -- inlineUnconditionally will catch the type applicn
- -- and inline it unconditionally, without ever trying
- -- to simplify the RHS
+ -- The silly binding for g* must be IMustBeINLINEs, so that
+ -- we simply substitute for g* throughout.
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Eta expansion}
+%* *
+%************************************************************************
+
+ Try eta expansion for RHSs
+
+We go for:
+ \x1..xn -> N ==> \x1..xn y1..ym -> N y1..ym
+ AND
+ N E1..En ==> let z1=E1 .. zn=En in \y1..ym -> N z1..zn y1..ym
+
+where (in both cases) N is a NORMAL FORM (i.e. no redexes anywhere)
+wanting a suitable number of extra args.
+
+NB: the Ei may have unlifted type, but the simplifier (which is applied
+to the result) deals OK with this).
+
+There is no point in looking for a combination of the two,
+because that would leave use with some lets sandwiched between lambdas;
+but it's awkward to detect that case, so we don't bother.
+
+\begin{code}
+tryEtaExpansion :: InExpr -> SimplM InExpr
+tryEtaExpansion rhs
+ | not opt_SimplDoLambdaEtaExpansion
+ || exprIsTrivial rhs -- Don't eta-expand a trival RHS
+ || null y_tys -- No useful expansion
+ = returnSmpl rhs
+
+ | otherwise -- Consider eta expansion
+ = newIds y_tys ( \ y_bndrs ->
+ tick (EtaExpansion (head y_bndrs)) `thenSmpl_`
+ mapAndUnzipSmpl bind_z_arg args `thenSmpl` (\ (z_binds, z_args) ->
+ returnSmpl (mkLams x_bndrs $
+ mkLets (catMaybes z_binds) $
+ mkLams y_bndrs $
+ mkApps (mkApps fun z_args) (map Var y_bndrs))))
+ where
+ (x_bndrs, body) = collectValBinders rhs
+ (fun, args) = collectArgs body
+ no_of_xs = length x_bndrs
+ fun_arity = case fun of
+ Var v -> arityLowerBound (getIdArity v)
+ other -> 0
+
+ bind_z_arg arg | exprIsTrivial arg = returnSmpl (Nothing, arg)
+ | otherwise = newId (coreExprType arg) $ \ z ->
+ returnSmpl (Just (NonRec z arg), Var z)
+
+ -- Note: I used to try to avoid the coreExprType call by using
+ -- the type of the binder. But this type doesn't necessarily
+ -- belong to the same substitution environment as this rhs;
+ -- and we are going to make extra term binders (y_bndrs) from the type
+ -- which will be processed with the rhs substitution environment.
+ -- This only went wrong in a mind bendingly complicated case.
+ (potential_extra_arg_tys, inner_ty) = splitFunTys (coreExprType body)
+
+ y_tys :: [InType]
+ y_tys = take no_extras_wanted potential_extra_arg_tys
+
+ no_extras_wanted :: Int
+ no_extras_wanted =
+
+ -- We used to expand the arity to the previous arity fo the
+ -- function; but this is pretty dangerous. Consdier
+ -- f = \xy -> e
+ -- so that f has arity 2. Now float something into f's RHS:
+ -- f = let z = BIG in \xy -> e
+ -- The last thing we want to do now is to put some lambdas
+ -- outside, to get
+ -- f = \xy -> let z = BIG in e
+ --
+ -- (bndr_arity - no_of_xs) `max`
+
+ -- See if the body could obviously do with more args
+ (fun_arity - valArgCount args) `max`
+
+ -- Finally, see if it's a state transformer, and xs is non-null
+ -- (so it's also a function not a thunk) in which
+ -- case we eta-expand on principle! This can waste work,
+ -- but usually doesn't.
+ -- I originally checked for a singleton type [ty] in this case
+ -- but then I found a situation in which I had
+ -- \ x -> let {..} in \ s -> f (...) s
+ -- AND f RETURNED A FUNCTION. That is, 's' wasn't the only
+ -- potential extra arg.
+ case (x_bndrs, potential_extra_arg_tys) of
+ (_:_, ty:_) -> case splitTyConApp_maybe ty of
+ Just (tycon,_) | tycon == statePrimTyCon -> 1
+ other -> 0
+ other -> 0
\end{code}
e.g. \ x y -> f x y ===> f
It is used
- a) Before constructing an Unfolding, to
- try to make the unfolding smaller;
+-- OLD
+-- a) Before constructing an Unfolding, to
+-- try to make the unfolding smaller;
b) In tidyCoreExpr, which is done just before converting to STG.
But we only do this if
The idea is that lambdas are often quite helpful: they indicate
head normal forms, so we don't want to chuck them away lightly.
- ii) It exposes a simple variable or a type application; in short
- it exposes a "trivial" expression. (exprIsTrivial)
+-- OLD: in core2stg we want to do this even if the result isn't trivial
+-- ii) It exposes a simple variable or a type application; in short
+-- it exposes a "trivial" expression. (exprIsTrivial)
\begin{code}
etaCoreExpr :: CoreExpr -> CoreExpr
-- lambda into a bottom variable. Sigh
etaCoreExpr expr@(Lam bndr body)
- | opt_DoEtaReduction
= check (reverse binders) body
where
(binders, body) = collectBinders expr
check [] body
- | exprIsTrivial body && not (any (`elemVarSet` body_fvs) binders)
+ | not (any (`elemVarSet` body_fvs) binders)
= body -- Success!
where
body_fvs = exprFreeVars body
%************************************************************************
%* *
-\subsection{Eta expansion}
-%* *
-%************************************************************************
-
-@etaExpandCount@ takes an expression, E, and returns an integer n,
-such that
-
- E ===> (\x1::t1 x1::t2 ... xn::tn -> E x1 x2 ... xn)
-
-is a safe transformation. In particular, the transformation should
-not cause work to be duplicated, unless it is ``cheap'' (see
-@manifestlyCheap@ below).
-
-@etaExpandCount@ errs on the conservative side. It is always safe to
-return 0.
-
-An application of @error@ is special, because it can absorb as many
-arguments as you care to give it. For this special case we return
-100, to represent "infinity", which is a bit of a hack.
-
-\begin{code}
-etaExpandCount :: CoreExpr
- -> Int -- Number of extra args you can safely abstract
-
-etaExpandCount (Lam b body)
- | isId b
- = 1 + etaExpandCount body
-
-etaExpandCount (Let bind body)
- | all exprIsCheap (rhssOfBind bind)
- = etaExpandCount body
-
-etaExpandCount (Case scrut _ alts)
- | exprIsCheap scrut
- = minimum [etaExpandCount rhs | (_,_,rhs) <- alts]
-
-etaExpandCount fun@(Var _) = eta_fun fun
-
-etaExpandCount (App fun (Type ty))
- = eta_fun fun
-etaExpandCount (App fun arg)
- | exprIsCheap arg = case etaExpandCount fun of
- 0 -> 0
- n -> n-1 -- Knock off one
-
-etaExpandCount other = 0 -- Give up
- -- Lit, Con, Prim,
- -- non-val Lam,
- -- Scc (pessimistic; ToDo),
- -- Let with non-whnf rhs(s),
- -- Case with non-whnf scrutinee
-
------------------------------
-eta_fun :: CoreExpr -- The function
- -> Int -- How many args it can safely be applied to
-
-eta_fun (App fun (Type ty)) = eta_fun fun
-eta_fun (Var v) = arityLowerBound (getIdArity v)
-eta_fun other = 0 -- Give up
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Case absorption and identity-case elimination}
%* *
%************************************************************************
\begin{code}
-mkCase :: SwitchChecker -> OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
+mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
\end{code}
@mkCase@ tries the following transformation (if possible):
variable is scrutinised multiple times.
\begin{code}
-mkCase sw_chkr scrut outer_bndr outer_alts
- | switchIsOn sw_chkr SimplCaseMerge
+mkCase scrut outer_bndr outer_alts
+ | opt_SimplCaseMerge
&& maybeToBool maybe_case_in_default
- = tick CaseMerge `thenSmpl_`
+ = tick (CaseMerge outer_bndr) `thenSmpl_`
returnSmpl (Case scrut outer_bndr new_alts)
-- Warning: don't call mkCase recursively!
-- Firstly, there's no point, because inner alts have already had
and similar friends.
\begin{code}
-mkCase sw_chkr scrut case_bndr alts
+mkCase scrut case_bndr alts
| all identity_alt alts
- = tick CaseIdentity `thenSmpl_`
+ = tick (CaseIdentity case_bndr) `thenSmpl_`
returnSmpl scrut
where
identity_alt (DEFAULT, [], Var v) = v == case_bndr
The catch-all case
\begin{code}
-mkCase sw_chkr other_scrut case_bndr other_alts
+mkCase other_scrut case_bndr other_alts
= returnSmpl (Case other_scrut case_bndr other_alts)
\end{code}
matches (DEFAULT, _, _) = True
matches (con1, _, _) = con == con1
+
+
+mkCoerce to_ty (Note (Coerce _ from_ty) expr)
+ | to_ty == from_ty = expr
+ | otherwise = Note (Coerce to_ty from_ty) expr
+mkCoerce to_ty expr
+ = Note (Coerce to_ty (coreExprType expr)) expr
\end{code}
\section[Simplify]{The main module of the simplifier}
\begin{code}
-module Simplify ( simplBind ) where
+module Simplify ( simplTopBinds, simplExpr ) where
#include "HsVersions.h"
-import CmdLineOpts ( switchIsOn, opt_SccProfilingOn, opt_PprStyle_Debug,
- opt_NoPreInlining, opt_DictsStrict, opt_D_dump_inlinings,
+import CmdLineOpts ( intSwitchSet,
+ opt_SccProfilingOn, opt_PprStyle_Debug, opt_SimplDoEtaReduction,
+ opt_SimplNoPreInlining, opt_DictsStrict, opt_SimplPedanticBottoms,
+ opt_SimplDoCaseElim,
SimplifierSwitch(..)
)
import SimplMonad
-import SimplUtils ( mkCase, etaCoreExpr, etaExpandCount, findAlt, mkRhsTyLam,
- simplBinder, simplBinders, simplIds, findDefault
+import SimplUtils ( mkCase, transformRhs, findAlt,
+ simplBinder, simplBinders, simplIds, findDefault, mkCoerce
)
-import Var ( TyVar, mkSysTyVar, tyVarKind )
+import Var ( TyVar, mkSysTyVar, tyVarKind, maybeModifyIdInfo )
import VarEnv
import VarSet
-import Id ( Id, idType,
- getIdUnfolding, setIdUnfolding,
+import Id ( Id, idType, idInfo, idUnique,
+ getIdUnfolding, setIdUnfolding, isExportedId,
getIdSpecialisation, setIdSpecialisation,
getIdDemandInfo, setIdDemandInfo,
getIdArity, setIdArity,
- getIdStrictness,
- setInlinePragma, getInlinePragma, idMustBeINLINEd,
- idWantsToBeINLINEd
+ getIdStrictness,
+ setInlinePragma, getInlinePragma, idMustBeINLINEd
)
import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
- ArityInfo, atLeastArity, arityLowerBound, unknownArity
+ ArityInfo(..), atLeastArity, arityLowerBound, unknownArity,
+ specInfo, inlinePragInfo, zapLamIdInfo
)
import Demand ( Demand, isStrict, wwLazy )
import Const ( isWHNFCon, conOkForAlt )
import ConFold ( tryPrimOp )
-import PrimOp ( PrimOp, primOpStrictness )
-import DataCon ( DataCon, dataConNumInstArgs, dataConStrictMarks, dataConSig, dataConArgTys )
+import PrimOp ( PrimOp, primOpStrictness, primOpType )
+import DataCon ( DataCon, dataConNumInstArgs, dataConRepStrictness, dataConSig, dataConArgTys )
import Const ( Con(..) )
-import MagicUFs ( applyMagicUnfoldingFun )
-import Name ( isExported, isLocallyDefined )
+import Name ( isLocallyDefined )
import CoreSyn
-import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
- mkUnfolding, smallEnoughToInline,
- isEvaldUnfolding, unfoldAlways
- )
-import CoreUtils ( IdSubst, SubstCoreExpr(..),
- cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
- coreExprType, coreAltsType, exprIsCheap, substExpr,
+import CoreFVs ( exprFreeVars )
+import CoreUnfold ( Unfolding(..), mkUnfolding, callSiteInline,
+ isEvaldUnfolding, blackListed )
+import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
+ coreExprType, coreAltsType, exprIsCheap, exprArity,
+ exprOkForSpeculation,
FormSummary(..), mkFormSummary, whnfOrBottom
)
-import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, substSpecEnv )
+import Rules ( lookupRule )
import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC )
-import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, fullSubstTy,
+import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType,
mkFunTy, splitFunTys, splitTyConApp_maybe, splitFunTy_maybe,
- applyTy, applyTys, funResultTy, isDictTy, isDataType
+ funResultTy, isDictTy, isDataType, applyTy, applyTys, mkFunTys
+ )
+import Subst ( Subst, mkSubst, emptySubst, substExpr, substTy,
+ substEnv, lookupInScope, lookupSubst, substRules
)
import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon )
import TysPrim ( realWorldStatePrimTy )
-import PrelVals ( realWorldPrimId )
-import BasicTypes ( StrictnessMark(..) )
+import PrelInfo ( realWorldPrimId )
+import BasicTypes ( TopLevelFlag(..), isTopLevel )
import Maybes ( maybeToBool )
-import Util ( zipWithEqual, stretchZipEqual )
+import Util ( zipWithEqual, stretchZipEqual, lengthExceeds )
import PprCore
import Outputable
\end{code}
The guts of the simplifier is in this module, but the driver
-loop for the simplifier is in SimplPgm.lhs.
+loop for the simplifier is in SimplCore.lhs.
+
+
+%************************************************************************
+%* *
+\subsection{Bindings}
+%* *
+%************************************************************************
+
+\begin{code}
+simplTopBinds :: [InBind] -> SimplM [OutBind]
+
+simplTopBinds binds
+ = -- Put all the top-level binders into scope at the start
+ -- so that if a transformation rule has unexpectedly brought
+ -- anything into scope, then we don't get a complaint about that.
+ -- It's rather as if the top-level binders were imported.
+ extendInScopes top_binders $
+ simpl_binds binds `thenSmpl` \ (binds', _) ->
+ freeTick SimplifierDone `thenSmpl_`
+ returnSmpl binds'
+ where
+ top_binders = bindersOfBinds binds
+
+ simpl_binds [] = returnSmpl ([], panic "simplTopBinds corner")
+ simpl_binds (NonRec bndr rhs : binds) = simplLazyBind TopLevel bndr bndr rhs (simpl_binds binds)
+ simpl_binds (Rec pairs : binds) = simplRecBind TopLevel pairs (map fst pairs) (simpl_binds binds)
+
+
+simplRecBind :: TopLevelFlag -> [(InId, InExpr)] -> [OutId]
+ -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+simplRecBind top_lvl pairs bndrs' thing_inside
+ = go pairs bndrs' `thenSmpl` \ (binds', stuff) ->
+ returnSmpl (addBind (Rec (flattenBinds binds')) stuff)
+ where
+ go [] _ = thing_inside `thenSmpl` \ stuff ->
+ returnSmpl ([], stuff)
+
+ go ((bndr, rhs) : pairs) (bndr' : bndrs')
+ = simplLazyBind top_lvl bndr bndr' rhs (go pairs bndrs')
+ -- Don't float unboxed bindings out,
+ -- because we can't "rec" them
+\end{code}
%************************************************************************
\begin{code}
-simplExpr :: CoreExpr -> SimplCont -> SimplM CoreExpr
-simplExpr expr cont = simplExprB expr cont `thenSmpl` \ (binds, (_, body)) ->
- returnSmpl (mkLetBinds binds body)
+simplExpr :: CoreExpr -> SimplM CoreExpr
+simplExpr expr = getSubst `thenSmpl` \ subst ->
+ simplExprC expr (Stop (substTy subst (coreExprType expr)))
+ -- The type in the Stop continuation is usually not used
+ -- It's only needed when discarding continuations after finding
+ -- a function that returns bottom
-simplExprB :: InExpr -> SimplCont -> SimplM OutExprStuff
+simplExprC :: CoreExpr -> SimplCont -> SimplM CoreExpr
+ -- Simplify an expression, given a continuation
-simplExprB (Note InlineCall (Var v)) cont
- = simplVar True v cont
+simplExprC expr cont = simplExprF expr cont `thenSmpl` \ (floats, (_, body)) ->
+ returnSmpl (mkLets floats body)
-simplExprB (Var v) cont
- = simplVar False v cont
+simplExprF :: InExpr -> SimplCont -> SimplM OutExprStuff
+ -- Simplify an expression, returning floated binds
-simplExprB expr@(Con (PrimOp op) args) cont
- = simplType (coreExprType expr) `thenSmpl` \ expr_ty ->
- getInScope `thenSmpl` \ in_scope ->
- getSubstEnv `thenSmpl` \ se ->
- let
- (val_arg_demands, _) = primOpStrictness op
+simplExprF (Var v) cont
+ = simplVar v cont
- -- Main game plan: loop through the arguments, simplifying
- -- each of them with an ArgOf continuation. Getting the right
- -- cont_ty in the ArgOf continuation is a bit of a nuisance.
- go [] ds args' = rebuild_primop (reverse args')
- go (arg:args) ds args'
- | isTypeArg arg = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
- go args ds (arg':args')
- go (arg:args) (d:ds) args'
- | not (isStrict d) = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
- go args ds (arg':args')
- | otherwise = setSubstEnv se (simplExprB arg (mk_cont args ds args'))
-
- cont_ty = contResultType in_scope expr_ty cont
- mk_cont args ds args' = ArgOf NoDup (\ arg' -> go args ds (arg':args')) cont_ty
- in
- go args val_arg_demands []
- where
+simplExprF expr@(Con (PrimOp op) args) cont
+ = getSubstEnv `thenSmpl` \ se ->
+ prepareArgs (ppr op)
+ (primOpType op)
+ (primOpStrictness op)
+ (pushArgs se args cont) $ \ args1 cont1 ->
- rebuild_primop args'
- = -- Try the prim op simplification
+ let
+ -- Boring... we may have too many arguments now, so we push them back
+ n_args = length args
+ args2 = ASSERT( length args1 >= n_args )
+ take n_args args1
+ cont2 = pushArgs emptySubstEnv (drop n_args args1) cont1
+ in
+ -- Try the prim op simplification
-- It's really worth trying simplExpr again if it succeeds,
-- because you can find
-- case (eqChar# x 'a') of ...
-- ==>
-- case (case x of 'a' -> True; other -> False) of ...
- case tryPrimOp op args' of
- Just e' -> zapSubstEnv (simplExprB e' cont)
- Nothing -> rebuild (Con (PrimOp op) args') cont
+ case tryPrimOp op args2 of
+ Just e' -> zapSubstEnv (simplExprF e' cont2)
+ Nothing -> rebuild (Con (PrimOp op) args2) cont2
-simplExprB (Con con@(DataCon _) args) cont
- = simplConArgs args $ \ args' ->
- rebuild (Con con args') cont
+simplExprF (Con con@(DataCon _) args) cont
+ = freeTick LeafVisit `thenSmpl_`
+ simplConArgs args ( \ args' ->
+ rebuild (Con con args') cont)
-simplExprB expr@(Con con@(Literal _) args) cont
+simplExprF expr@(Con con@(Literal _) args) cont
= ASSERT( null args )
+ freeTick LeafVisit `thenSmpl_`
rebuild expr cont
-simplExprB (App fun arg) cont
+simplExprF (App fun arg) cont
= getSubstEnv `thenSmpl` \ se ->
- simplExprB fun (ApplyTo NoDup arg se cont)
+ simplExprF fun (ApplyTo NoDup arg se cont)
-simplExprB (Case scrut bndr alts) cont
+simplExprF (Case scrut bndr alts) cont
= getSubstEnv `thenSmpl` \ se ->
- simplExprB scrut (Select NoDup bndr alts se cont)
+ simplExprF scrut (Select NoDup bndr alts se cont)
+
+
+simplExprF (Let (Rec pairs) body) cont
+ = simplIds (map fst pairs) $ \ bndrs' ->
+ -- NB: bndrs' don't have unfoldings or spec-envs
+ -- We add them as we go down, using simplPrags
-simplExprB (Note (Coerce to from) e) cont
- | to == from = simplExprB e cont
- | otherwise = getSubstEnv `thenSmpl` \ se ->
- simplExprB e (CoerceIt NoDup to se cont)
+ simplRecBind NotTopLevel pairs bndrs' (simplExprF body cont)
+
+simplExprF expr@(Lam _ _) cont = simplLam expr cont
+simplExprF (Type ty) cont
+ = ASSERT( case cont of { Stop _ -> True; ArgOf _ _ _ -> True; other -> False } )
+ simplType ty `thenSmpl` \ ty' ->
+ rebuild (Type ty') cont
+
+simplExprF (Note (Coerce to from) e) cont
+ | to == from = simplExprF e cont
+ | otherwise = getSubst `thenSmpl` \ subst ->
+ simplExprF e (CoerceIt (substTy subst to) cont)
-- hack: we only distinguish subsumed cost centre stacks for the purposes of
-- inlining. All other CCCSs are mapped to currentCCS.
-simplExprB (Note (SCC cc) e) cont
+simplExprF (Note (SCC cc) e) cont
= setEnclosingCC currentCCS $
- simplExpr e Stop `thenSmpl` \ e ->
+ simplExpr e `thenSmpl` \ e ->
rebuild (mkNote (SCC cc) e) cont
-simplExprB (Note note e) cont
- = simplExpr e Stop `thenSmpl` \ e' ->
- rebuild (mkNote note e') cont
+simplExprF (Note InlineCall e) cont
+ = simplExprF e (InlinePlease cont)
+
+-- Comments about the InlineMe case
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Don't inline in the RHS of something that has an
+-- inline pragma. But be careful that the InScopeEnv that
+-- we return does still have inlinings on!
+--
+-- It really is important to switch off inlinings. This function
+-- may be inlinined in other modules, so we don't want to remove
+-- (by inlining) calls to functions that have specialisations, or
+-- that may have transformation rules in an importing scope.
+-- E.g. {-# INLINE f #-}
+-- f x = ...g...
+-- and suppose that g is strict *and* has specialisations.
+-- If we inline g's wrapper, we deny f the chance of getting
+-- the specialised version of g when f is inlined at some call site
+-- (perhaps in some other module).
+
+simplExprF (Note InlineMe e) cont
+ = case cont of
+ Stop _ -> -- Totally boring continuation
+ -- Don't inline inside an INLINE expression
+ switchOffInlining (simplExpr e) `thenSmpl` \ e' ->
+ rebuild (mkNote InlineMe e') cont
+
+ other -> -- Dissolve the InlineMe note if there's
+ -- an interesting context of any kind to combine with
+ -- (even a type application -- anything except Stop)
+ simplExprF e cont
-- A non-recursive let is dealt with by simplBeta
-simplExprB (Let (NonRec bndr rhs) body) cont
- = getSubstEnv `thenSmpl` \ se ->
- simplBeta bndr rhs se body cont
-
-simplExprB (Let (Rec pairs) body) cont
- = simplRecBind pairs (simplExprB body cont)
-
--- Type-beta reduction
-simplExprB expr@(Lam bndr body) cont@(ApplyTo _ (Type ty_arg) arg_se body_cont)
- = ASSERT( isTyVar bndr )
- tick BetaReduction `thenSmpl_`
- setSubstEnv arg_se (simplType ty_arg) `thenSmpl` \ ty' ->
- extendTySubst bndr ty' $
- simplExprB body body_cont
-
--- Ordinary beta reduction
-simplExprB expr@(Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
- = tick BetaReduction `thenSmpl_`
- simplBeta bndr' arg arg_se body body_cont
+simplExprF (Let (NonRec bndr rhs) body) cont
+ = getSubstEnv `thenSmpl` \ se ->
+ simplBeta bndr rhs se (contResultType cont) $
+ simplExprF body cont
+\end{code}
+
+
+---------------------------------
+
+\begin{code}
+simplLam fun cont
+ = go fun cont
where
- bndr' = zapLambdaBndr bndr body body_cont
+ zap_it = mkLamBndrZapper fun (countArgs cont)
+ cont_ty = contResultType cont
+
+ -- Type-beta reduction
+ go (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont)
+ = ASSERT( isTyVar bndr )
+ tick (BetaReduction bndr) `thenSmpl_`
+ getInScope `thenSmpl` \ in_scope ->
+ let
+ ty' = substTy (mkSubst in_scope arg_se) ty_arg
+ in
+ extendSubst bndr (DoneTy ty')
+ (go body body_cont)
+
+ -- Ordinary beta reduction
+ go (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
+ = tick (BetaReduction bndr) `thenSmpl_`
+ simplBeta zapped_bndr arg arg_se cont_ty
+ (go body body_cont)
+ where
+ zapped_bndr = zap_it bndr
+
+ -- Not enough args
+ go lam@(Lam _ _) cont = completeLam [] lam cont
+
+ -- Exactly enough args
+ go expr cont = simplExprF expr cont
-simplExprB (Lam bndr body) cont
+
+-- completeLam deals with the case where a lambda doesn't have an ApplyTo
+-- continuation. Try for eta reduction, but *only* if we get all
+-- the way to an exprIsTrivial expression.
+-- 'acc' holds the simplified binders, in reverse order
+
+completeLam acc (Lam bndr body) cont
= simplBinder bndr $ \ bndr' ->
- simplExpr body Stop `thenSmpl` \ body' ->
- rebuild (Lam bndr' body') cont
+ completeLam (bndr':acc) body cont
-simplExprB (Type ty) cont
- = ASSERT( case cont of { Stop -> True; ArgOf _ _ _ -> True; other -> False } )
- simplType ty `thenSmpl` \ ty' ->
- rebuild (Type ty') cont
-\end{code}
+completeLam acc body cont
+ = simplExpr body `thenSmpl` \ body' ->
+ case (opt_SimplDoEtaReduction, check_eta acc body') of
+ (True, Just body'') -- Eta reduce!
+ -> tick (EtaReduction (head acc)) `thenSmpl_`
+ rebuild body'' cont
----------------------------------
-\begin{code}
-simplArg :: InArg -> SimplM OutArg
-simplArg arg = simplExpr arg Stop
+ other -> -- No eta reduction
+ rebuild (foldl (flip Lam) body' acc) cont
+ -- Remember, acc is the reversed binders
+ where
+ -- NB: the binders are reversed
+ check_eta (b : bs) (App fun arg)
+ | (varToCoreExpr b `cheapEqExpr` arg)
+ = check_eta bs fun
+
+ check_eta [] body
+ | exprIsTrivial body && -- ONLY if the body is trivial
+ not (any (`elemVarSet` body_fvs) acc)
+ = Just body -- Success!
+ where
+ body_fvs = exprFreeVars body
+
+ check_eta _ _ = Nothing -- Bale out
+
+mkLamBndrZapper :: CoreExpr -- Function
+ -> Int -- Number of args
+ -> Id -> Id -- Use this to zap the binders
+mkLamBndrZapper fun n_args
+ | saturated fun n_args = \b -> b
+ | otherwise = \b -> maybeModifyIdInfo zapLamIdInfo b
+ where
+ saturated (Lam b e) 0 = False
+ saturated (Lam b e) n = saturated e (n-1)
+ saturated e n = True
\end{code}
+
---------------------------------
simplConArgs makes sure that the arguments all end up being atomic.
-That means it may generate some Lets, hence the
+That means it may generate some Lets, hence the strange type
\begin{code}
simplConArgs :: [InArg] -> ([OutArg] -> SimplM OutExprStuff) -> SimplM OutExprStuff
= thing_inside []
simplConArgs (arg:args) thing_inside
- = switchOffInlining (simplArg arg) `thenSmpl` \ arg' ->
+ = switchOffInlining (simplExpr arg) `thenSmpl` \ arg' ->
-- Simplify the RHS with inlining switched off, so that
-- only absolutely essential things will happen.
\begin{code}
simplType :: InType -> SimplM OutType
simplType ty
- = getTyEnv `thenSmpl` \ (ty_subst, in_scope) ->
- returnSmpl (fullSubstTy ty_subst in_scope ty)
+ = getSubst `thenSmpl` \ subst ->
+ returnSmpl (substTy subst ty)
\end{code}
-\begin{code}
--- Find out whether the lambda is saturated,
--- if not zap the over-optimistic info in the binder
-
-zapLambdaBndr bndr body body_cont
- | isTyVar bndr || safe_info || definitely_saturated 20 body body_cont
- -- The "20" is to catch pathalogical cases with bazillions of arguments
- -- because we are using an n**2 algorithm here
- = bndr -- No need to zap
- | otherwise
- = setInlinePragma (setIdDemandInfo bndr wwLazy)
- safe_inline_prag
-
- where
- inline_prag = getInlinePragma bndr
- demand = getIdDemandInfo bndr
-
- safe_info = is_safe_inline_prag && not (isStrict demand)
-
- is_safe_inline_prag = case inline_prag of
- ICanSafelyBeINLINEd StrictOcc nalts -> False
- ICanSafelyBeINLINEd LazyOcc nalts -> False
- other -> True
-
- safe_inline_prag = case inline_prag of
- ICanSafelyBeINLINEd _ nalts
- -> ICanSafelyBeINLINEd InsideLam nalts
- other -> inline_prag
-
- definitely_saturated :: Int -> CoreExpr -> SimplCont -> Bool
- definitely_saturated 0 _ _ = False -- Too expensive to find out
- definitely_saturated n (Lam _ body) (ApplyTo _ _ _ cont) = definitely_saturated (n-1) body cont
- definitely_saturated n (Lam _ _) other_cont = False
- definitely_saturated n _ _ = True
-\end{code}
-
%************************************************************************
%* *
-\subsection{Variables}
+\subsection{Binding}
%* *
%************************************************************************
-Coercions
-~~~~~~~~~
-\begin{code}
-simplVar inline_call var cont
- = getValEnv `thenSmpl` \ (id_subst, in_scope) ->
- case lookupVarEnv id_subst var of
- Just (Done e)
- -> zapSubstEnv (simplExprB e cont)
-
- Just (SubstMe e ty_subst id_subst)
- -> setSubstEnv (ty_subst, id_subst) (simplExprB e cont)
-
- Nothing -> let
- var' = case lookupVarSet in_scope var of
- Just v' -> v'
- Nothing ->
-#ifdef DEBUG
- if isLocallyDefined var && not (idMustBeINLINEd var) then
- -- Not in scope
- pprTrace "simplVar:" (ppr var) var
- else
-#endif
- var
- in
- getSwitchChecker `thenSmpl` \ sw_chkr ->
- completeVar sw_chkr in_scope inline_call var' cont
-
-completeVar sw_chkr in_scope inline_call var cont
-
-{- MAGIC UNFOLDINGS NOT USED NOW
- | maybeToBool maybe_magic_result
- = tick MagicUnfold `thenSmpl_`
- magic_result
--}
- -- Look for existing specialisations before trying inlining
- | maybeToBool maybe_specialisation
- = tick SpecialisationDone `thenSmpl_`
- setSubstEnv (spec_bindings, emptyVarEnv) (
- -- See note below about zapping the substitution here
-
- simplExprB spec_template remaining_cont
- )
+@simplBeta@ is used for non-recursive lets in expressions,
+as well as true beta reduction.
- -- Don't actually inline the scrutinee when we see
- -- case x of y { .... }
- -- and x has unfolding (C a b). Why not? Because
- -- we get a silly binding y = C a b. If we don't
- -- inline knownCon can directly substitute x for y instead.
- | has_unfolding && var_is_case_scrutinee && unfolding_is_constr
- = knownCon (Var var) con con_args cont
+Very similar to @simplLazyBind@, but not quite the same.
- -- Look for an unfolding. There's a binding for the
- -- thing, but perhaps we want to inline it anyway
- | has_unfolding && (inline_call || ok_to_inline)
- = getEnclosingCC `thenSmpl` \ encl_cc ->
- if must_be_unfolded || costCentreOk encl_cc var
- then -- OK to unfold
-
- tickUnfold var `thenSmpl_` (
-
- zapSubstEnv $
- -- The template is already simplified, so don't re-substitute.
- -- This is VITAL. Consider
- -- let x = e in
- -- let y = \z -> ...x... in
- -- \ x -> ...y...
- -- We'll clone the inner \x, adding x->x' in the id_subst
- -- Then when we inline y, we must *not* replace x by x' in
- -- the inlined copy!!
-#ifdef DEBUG
- if opt_D_dump_inlinings then
- pprTrace "Inlining:" (ppr var <+> ppr unf_template) $
- simplExprB unf_template cont
- else
-#endif
- simplExprB unf_template cont
- )
- else
+\begin{code}
+simplBeta :: InId -- Binder
+ -> InExpr -> SubstEnv -- Arg, with its subst-env
+ -> OutType -- Type of thing computed by the context
+ -> SimplM OutExprStuff -- The body
+ -> SimplM OutExprStuff
#ifdef DEBUG
- pprTrace "Inlining disallowed due to CC:\n" (ppr encl_cc <+> ppr unf_template <+> ppr (coreExprCc unf_template)) $
+simplBeta bndr rhs rhs_se cont_ty thing_inside
+ | isTyVar bndr
+ = pprPanic "simplBeta" (ppr bndr <+> ppr rhs)
#endif
- -- Can't unfold because of bad cost centre
- rebuild (Var var) cont
- | inline_call -- There was an InlineCall note, but we didn't inline!
- = rebuild (Note InlineCall (Var var)) cont
+simplBeta bndr rhs rhs_se cont_ty thing_inside
+ | preInlineUnconditionally bndr && not opt_SimplNoPreInlining
+ = tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ extendSubst bndr (ContEx rhs_se rhs) thing_inside
| otherwise
- = rebuild (Var var) cont
-
- where
- unfolding = getIdUnfolding var
-
-{- MAGIC UNFOLDINGS NOT USED CURRENTLY
- ---------- Magic unfolding stuff
- maybe_magic_result = case unfolding of
- MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
- cont
- other -> Nothing
- Just magic_result = maybe_magic_result
--}
+ = -- Simplify the RHS
+ simplBinder bndr $ \ bndr' ->
+ simplArg (idType bndr') (getIdDemandInfo bndr)
+ rhs rhs_se cont_ty $ \ rhs' ->
+
+ -- Now complete the binding and simplify the body
+ completeBeta bndr bndr' rhs' thing_inside
+
+completeBeta bndr bndr' rhs' thing_inside
+ | isUnLiftedType (idType bndr') && not (exprOkForSpeculation rhs')
+ -- Make a case expression instead of a let
+ -- These can arise either from the desugarer,
+ -- or from beta reductions: (\x.e) (x +# y)
+ = getInScope `thenSmpl` \ in_scope ->
+ thing_inside `thenSmpl` \ (floats, (_, body)) ->
+ returnSmpl ([], (in_scope, Case rhs' bndr' [(DEFAULT, [], mkLets floats body)]))
- ---------- Unfolding stuff
- has_unfolding = case unfolding of
- CoreUnfolding _ _ _ -> True
- other -> False
- CoreUnfolding form guidance unf_template = unfolding
-
- -- overrides cost-centre business
- must_be_unfolded = case getInlinePragma var of
- IMustBeINLINEd -> True
- _ -> False
-
- ok_to_inline = okToInline sw_chkr in_scope var form guidance cont
- unfolding_is_constr = case unf_template of
- Con con _ -> conOkForAlt con
- other -> False
- Con con con_args = unf_template
+ | otherwise
+ = completeBinding bndr bndr' rhs' thing_inside
+\end{code}
- ---------- Specialisation stuff
- ty_args = initial_ty_args cont
- remaining_cont = drop_ty_args cont
- maybe_specialisation = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args
- Just (spec_bindings, spec_template) = maybe_specialisation
- initial_ty_args (ApplyTo _ (Type ty) (ty_subst,_) cont)
- = fullSubstTy ty_subst in_scope ty : initial_ty_args cont
- -- Having to do the substitution here is a bit of a bore
- initial_ty_args other_cont = []
+\begin{code}
+simplArg :: OutType -> Demand
+ -> InExpr -> SubstEnv
+ -> OutType -- Type of thing computed by the context
+ -> (OutExpr -> SimplM OutExprStuff)
+ -> SimplM OutExprStuff
+simplArg arg_ty demand arg arg_se cont_ty thing_inside
+ | isStrict demand ||
+ isUnLiftedType arg_ty ||
+ (opt_DictsStrict && isDictTy arg_ty && isDataType arg_ty)
+ -- Return true only for dictionary types where the dictionary
+ -- has more than one component (else we risk poking on the component
+ -- of a newtype dictionary)
+ = getSubstEnv `thenSmpl` \ body_se ->
+ transformRhs arg `thenSmpl` \ t_arg ->
+ setSubstEnv arg_se (simplExprF t_arg (ArgOf NoDup cont_ty $ \ arg' ->
+ setSubstEnv body_se (thing_inside arg')
+ )) -- NB: we must restore body_se before carrying on with thing_inside!!
- drop_ty_args (ApplyTo _ (Type _) _ cont) = drop_ty_args cont
- drop_ty_args other_cont = other_cont
+ | otherwise
+ = simplRhs NotTopLevel True arg_ty arg arg_se thing_inside
+\end{code}
- ---------- Switches
- var_is_case_scrutinee = case cont of
- Select _ _ _ _ _ -> True
- other -> False
+completeBinding
+ - deals only with Ids, not TyVars
+ - take an already-simplified RHS
------------ costCentreOk
--- costCentreOk checks that it's ok to inline this thing
--- The time it *isn't* is this:
---
--- f x = let y = E in
--- scc "foo" (...y...)
---
--- Here y has a "current cost centre", and we can't inline it inside "foo",
--- regardless of whether E is a WHNF or not.
---
--- We can inline a top-level binding anywhere.
-
-costCentreOk ccs_encl x
- = not opt_SccProfilingOn
- || isSubsumedCCS ccs_encl -- can unfold anything into a subsumed scope
- || not (isLocallyDefined x)
-\end{code}
+It does *not* attempt to do let-to-case. Why? Because they are used for
+ - top-level bindings
+ (when let-to-case is impossible)
-%************************************************************************
-%* *
-\subsection{Bindings}
-%* *
-%************************************************************************
+ - many situations where the "rhs" is known to be a WHNF
+ (so let-to-case is inappropriate).
\begin{code}
-simplBind :: InBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
-
-simplBind (NonRec bndr rhs) thing_inside
- = simplTopRhs bndr rhs `thenSmpl` \ (binds, in_scope, rhs', arity) ->
- setInScope in_scope $
- completeBindNonRec (bndr `setIdArity` arity) rhs' thing_inside `thenSmpl` \ stuff ->
- returnSmpl (addBinds binds stuff)
-
-simplBind (Rec pairs) thing_inside
- = simplRecBind pairs thing_inside
- -- The assymetry between the two cases is a bit unclean
-
-simplRecBind :: [(InId, InExpr)] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
-simplRecBind pairs thing_inside
- = simplIds (map fst pairs) $ \ bndrs' ->
- -- NB: bndrs' don't have unfoldings or spec-envs
- -- We add them as we go down, using simplPrags
-
- go (pairs `zip` bndrs') `thenSmpl` \ (pairs', stuff) ->
- returnSmpl (addBind (Rec pairs') stuff)
- where
- go [] = thing_inside `thenSmpl` \ stuff ->
- returnSmpl ([], stuff)
-
- go (((bndr, rhs), bndr') : pairs)
- = simplTopRhs bndr rhs `thenSmpl` \ (rhs_binds, in_scope, rhs', arity) ->
- setInScope in_scope $
- completeBindRec bndr (bndr' `setIdArity` arity)
- rhs' (go pairs) `thenSmpl` \ (pairs', stuff) ->
- returnSmpl (flatten rhs_binds pairs', stuff)
-
- flatten (NonRec b r : binds) prs = (b,r) : flatten binds prs
- flatten (Rec prs1 : binds) prs2 = prs1 ++ flatten binds prs2
- flatten [] prs = prs
+completeBinding :: InId -- Binder
+ -> OutId -- New binder
+ -> OutExpr -- Simplified RHS
+ -> SimplM (OutStuff a) -- Thing inside
+ -> SimplM (OutStuff a)
+completeBinding old_bndr new_bndr new_rhs thing_inside
+ | isDeadBinder old_bndr -- This happens; for example, the case_bndr during case of
+ -- known constructor: case (a,b) of x { (p,q) -> ... }
+ -- Here x isn't mentioned in the RHS, so we don't want to
+ -- create the (dead) let-binding let x = (a,b) in ...
+ = thing_inside
-completeBindRec bndr bndr' rhs' thing_inside
- | postInlineUnconditionally bndr etad_rhs
+ | postInlineUnconditionally old_bndr new_rhs
+ -- Maybe we don't need a let-binding! Maybe we can just
+ -- inline it right away. Unlike the preInlineUnconditionally case
+ -- we are allowed to look at the RHS.
+ --
-- NB: a loop breaker never has postInlineUnconditionally True
-- and non-loop-breakers only have *forward* references
-- Hence, it's safe to discard the binding
- = tick PostInlineUnconditionally `thenSmpl_`
- extendIdSubst bndr (Done etad_rhs) thing_inside
+ = tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
+ extendSubst old_bndr (DoneEx new_rhs)
+ thing_inside
| otherwise
- = -- Here's the only difference from completeBindNonRec: we
- -- don't do simplBinder first, because we've already
- -- done simplBinder on the recursive binders
- simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
- modifyInScope bndr'' $
- thing_inside `thenSmpl` \ (pairs, res) ->
- returnSmpl ((bndr'', etad_rhs) : pairs, res)
- where
- etad_rhs = etaCoreExpr rhs'
-\end{code}
+ = getSubst `thenSmpl` \ subst ->
+ let
+ bndr_info = idInfo old_bndr
+ old_rules = specInfo bndr_info
+ new_rules = substRules subst old_rules
+
+ -- The new binding site Id needs its specialisations re-attached
+ bndr_w_arity = new_bndr `setIdArity` ArityAtLeast (exprArity new_rhs)
+
+ binding_site_id
+ | isEmptyCoreRules old_rules = bndr_w_arity
+ | otherwise = bndr_w_arity `setIdSpecialisation` new_rules
+
+ -- At the occurrence sites we want to know the unfolding,
+ -- and the occurrence info of the original
+ -- (simplBinder cleaned up the inline prag of the original
+ -- to eliminate un-stable info, in case this expression is
+ -- simplified a second time; hence the need to reattach it)
+ occ_site_id = binding_site_id
+ `setIdUnfolding` mkUnfolding new_rhs
+ `setInlinePragma` inlinePragInfo bndr_info
+ in
+ modifyInScope occ_site_id thing_inside `thenSmpl` \ stuff ->
+ returnSmpl (addBind (NonRec binding_site_id new_rhs) stuff)
+\end{code}
%************************************************************************
%* *
-\subsection{Right hand sides}
+\subsection{simplLazyBind}
%* *
%************************************************************************
-simplRhs basically just simplifies the RHS of a let(rec).
+simplLazyBind basically just simplifies the RHS of a let(rec).
It does two important optimisations though:
* It floats let(rec)s out of the RHS, even if they
* It does eta expansion
\begin{code}
-simplTopRhs :: InId -> InExpr
- -> SimplM ([OutBind], InScopeEnv, OutExpr, ArityInfo)
-simplTopRhs bndr rhs
- = getSubstEnv `thenSmpl` \ bndr_se ->
- simplRhs bndr bndr_se rhs
-
-simplRhs bndr bndr_se rhs
- | idWantsToBeINLINEd bndr -- Don't inline in the RHS of something that has an
- -- inline pragma. But be careful that the InScopeEnv that
- -- we return does still have inlinings on!
- = switchOffInlining (simplExpr rhs Stop) `thenSmpl` \ rhs' ->
- getInScope `thenSmpl` \ in_scope ->
- returnSmpl ([], in_scope, rhs', unknownArity)
+simplLazyBind :: TopLevelFlag
+ -> InId -> OutId
+ -> InExpr -- The RHS
+ -> SimplM (OutStuff a) -- The body of the binding
+ -> SimplM (OutStuff a)
+-- When called, the subst env is correct for the entire let-binding
+-- and hence right for the RHS.
+-- Also the binder has already been simplified, and hence is in scope
+
+simplLazyBind top_lvl bndr bndr' rhs thing_inside
+ | preInlineUnconditionally bndr && not opt_SimplNoPreInlining
+ = tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ getSubstEnv `thenSmpl` \ rhs_se ->
+ (extendSubst bndr (ContEx rhs_se rhs) thing_inside)
| otherwise
- = -- Swizzle the inner lets past the big lambda (if any)
- mkRhsTyLam rhs `thenSmpl` \ swizzled_rhs ->
-
- -- Simplify the swizzled RHS
- simplRhs2 bndr bndr_se swizzled_rhs `thenSmpl` \ (floats, (in_scope, rhs', arity)) ->
-
- if not (null floats) && exprIsWHNF rhs' then -- Do the float
- tick LetFloatFromLet `thenSmpl_`
- returnSmpl (floats, in_scope, rhs', arity)
- else -- Don't do it
- getInScope `thenSmpl` \ in_scope ->
- returnSmpl ([], in_scope, mkLetBinds floats rhs', arity)
+ = -- Simplify the RHS
+ getSubstEnv `thenSmpl` \ rhs_se ->
+
+ simplRhs top_lvl False {- Not ok to float unboxed -}
+ (idType bndr')
+ rhs rhs_se $ \ rhs' ->
+
+ -- Now compete the binding and simplify the body
+ completeBinding bndr bndr' rhs' thing_inside
\end{code}
----------------------------------------------------------
- Try eta expansion for RHSs
-We need to pass in the substitution environment for the RHS, because
-it might be different to the current one (see simplBeta, as called
-from simplExpr for an applied lambda). The binder needs to
\begin{code}
-simplRhs2 bndr bndr_se (Let bind body)
- = simplBind bind (simplRhs2 bndr bndr_se body)
-
-simplRhs2 bndr bndr_se rhs
- | null ids -- Prevent eta expansion for both thunks
- -- (would lose sharing) and variables (nothing gained).
- -- To see why we ignore it for thunks, consider
- -- let f = lookup env key in (f 1, f 2)
- -- We'd better not eta expand f just because it is
- -- always applied!
- --
- -- Also if there isn't a lambda at the top we use
- -- simplExprB so that we can do (more) let-floating
- = simplExprB rhs Stop `thenSmpl` \ (binds, (in_scope, rhs')) ->
- returnSmpl (binds, (in_scope, rhs', unknownArity))
-
- | otherwise -- Consider eta expansion
- = getSwitchChecker `thenSmpl` \ sw_chkr ->
- getInScope `thenSmpl` \ in_scope ->
- simplBinders tyvars $ \ tyvars' ->
- simplBinders ids $ \ ids' ->
-
- if switchIsOn sw_chkr SimplDoLambdaEtaExpansion
- && not (null extra_arg_tys)
+simplRhs :: TopLevelFlag
+ -> Bool -- True <=> OK to float unboxed (speculative) bindings
+ -> OutType -> InExpr -> SubstEnv
+ -> (OutExpr -> SimplM (OutStuff a))
+ -> SimplM (OutStuff a)
+simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside
+ = -- Swizzle the inner lets past the big lambda (if any)
+ -- and try eta expansion
+ transformRhs rhs `thenSmpl` \ t_rhs ->
+
+ -- Simplify it
+ setSubstEnv rhs_se (simplExprF t_rhs (Stop rhs_ty)) `thenSmpl` \ (floats, (in_scope', rhs')) ->
+
+ -- Float lets out of RHS
+ let
+ (floats_out, rhs'') | float_ubx = (floats, rhs')
+ | otherwise = splitFloats floats rhs'
+ in
+ if (isTopLevel top_lvl || exprIsWHNF rhs') && -- Float lets if (a) we're at the top level
+ not (null floats_out) -- or (b) it exposes a HNF
then
- tick EtaExpansion `thenSmpl_`
- setSubstEnv bndr_se (mapSmpl simplType extra_arg_tys)
- `thenSmpl` \ extra_arg_tys' ->
- newIds extra_arg_tys' $ \ extra_bndrs' ->
- simplExpr body (mk_cont extra_bndrs') `thenSmpl` \ body' ->
- let
- expanded_rhs = mkLams tyvars'
- $ mkLams ids'
- $ mkLams extra_bndrs' body'
- expanded_arity = atLeastArity (no_of_ids + no_of_extras)
- in
- returnSmpl ([], (in_scope, expanded_rhs, expanded_arity))
-
- else
- simplExpr body Stop `thenSmpl` \ body' ->
- let
- unexpanded_rhs = mkLams tyvars'
- $ mkLams ids' body'
- unexpanded_arity = atLeastArity no_of_ids
- in
- returnSmpl ([], (in_scope, unexpanded_rhs, unexpanded_arity))
-
+ tickLetFloat floats_out `thenSmpl_`
+ -- Do the float
+ --
+ -- There's a subtlety here. There may be a binding (x* = e) in the
+ -- floats, where the '*' means 'will be demanded'. So is it safe
+ -- to float it out? Answer no, but it won't matter because
+ -- we only float if arg' is a WHNF,
+ -- and so there can't be any 'will be demanded' bindings in the floats.
+ -- Hence the assert
+ WARN( any demanded_float floats_out, ppr floats_out )
+ setInScope in_scope' (thing_inside rhs'') `thenSmpl` \ stuff ->
+ -- in_scope' may be excessive, but that's OK;
+ -- it's a superset of what's in scope
+ returnSmpl (addBinds floats_out stuff)
+ else
+ -- Don't do the float
+ thing_inside (mkLets floats rhs')
+
+-- In a let-from-let float, we just tick once, arbitrarily
+-- choosing the first floated binder to identify it
+tickLetFloat (NonRec b r : fs) = tick (LetFloatFromLet b)
+tickLetFloat (Rec ((b,r):prs) : fs) = tick (LetFloatFromLet b)
+
+demanded_float (NonRec b r) = isStrict (getIdDemandInfo b) && not (isUnLiftedType (idType b))
+ -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
+demanded_float (Rec _) = False
+
+-- Don't float any unlifted bindings out, because the context
+-- is either a Rec group, or the top level, neither of which
+-- can tolerate them.
+splitFloats floats rhs
+ = go floats
where
- (tyvars, ids, body) = collectTyAndValBinders rhs
- no_of_ids = length ids
+ go [] = ([], rhs)
+ go (f:fs) | must_stay f = ([], mkLets (f:fs) rhs)
+ | otherwise = case go fs of
+ (out, rhs') -> (f:out, rhs')
- potential_extra_arg_tys :: [InType] -- NB: InType
- potential_extra_arg_tys = case splitFunTys (applyTys (idType bndr) (mkTyVarTys tyvars)) of
- (arg_tys, _) -> drop no_of_ids arg_tys
-
- extra_arg_tys :: [InType]
- extra_arg_tys = take no_extras_wanted potential_extra_arg_tys
- no_of_extras = length extra_arg_tys
-
- no_extras_wanted = -- Use information about how many args the fn is applied to
- (arity - no_of_ids) `max`
-
- -- See if the body could obviously do with more args
- etaExpandCount body `max`
-
- -- Finally, see if it's a state transformer, in which
- -- case we eta-expand on principle! This can waste work,
- -- but usually doesn't
- case potential_extra_arg_tys of
- [ty] | ty == realWorldStatePrimTy -> 1
- other -> 0
-
- arity = arityLowerBound (getIdArity bndr)
-
- mk_cont [] = Stop
- mk_cont (b:bs) = ApplyTo OkToDup (Var b) emptySubstEnv (mk_cont bs)
+ must_stay (Rec prs) = False -- No unlifted bindings in here
+ must_stay (NonRec b r) = isUnLiftedType (idType b)
\end{code}
+
%************************************************************************
%* *
-\subsection{Binding}
+\subsection{Variables}
%* *
%************************************************************************
\begin{code}
-simplBeta :: InId -- Binder
- -> InExpr -> SubstEnv -- Arg, with its subst-env
- -> InExpr -> SimplCont -- Lambda body
- -> SimplM OutExprStuff
+simplVar var cont
+ = freeTick LeafVisit `thenSmpl_`
+ getSubst `thenSmpl` \ subst ->
+ case lookupSubst subst var of
+ Just (DoneEx (Var v)) -> zapSubstEnv (simplVar v cont)
+ Just (DoneEx e) -> zapSubstEnv (simplExprF e cont)
+ Just (ContEx env' e) -> setSubstEnv env' (simplExprF e cont)
+
+ Nothing -> let
+ var' = case lookupInScope subst var of
+ Just v' -> v'
+ Nothing ->
#ifdef DEBUG
-simplBeta bndr rhs rhs_se body cont
- | isTyVar bndr
- = pprPanic "simplBeta" ((ppr bndr <+> ppr rhs) $$ ppr cont)
+ if isLocallyDefined var && not (idMustBeINLINEd var)
+ -- The idMustBeINLINEd test accouunts for the fact
+ -- that class method selectors don't have top level
+ -- bindings and hence aren't in scope.
+ then
+ -- Not in scope
+ pprTrace "simplVar:" (ppr var) var
+ else
#endif
+ var
+ in
+ getBlackList `thenSmpl` \ black_list ->
+ getInScope `thenSmpl` \ in_scope ->
-simplBeta bndr rhs rhs_se body cont
- | isUnLiftedType bndr_ty
- || (isStrict (getIdDemandInfo bndr) || is_dict bndr) && not (exprIsWHNF rhs)
- = tick Let2Case `thenSmpl_`
- getSubstEnv `thenSmpl` \ body_se ->
- setSubstEnv rhs_se $
- simplExprB rhs (Select NoDup bndr [(DEFAULT, [], body)] body_se cont)
-
- | preInlineUnconditionally bndr && not opt_NoPreInlining
- = tick PreInlineUnconditionally `thenSmpl_`
- case rhs_se of { (ty_subst, id_subst) ->
- extendIdSubst bndr (SubstMe rhs ty_subst id_subst) $
- simplExprB body cont }
-
- | otherwise
- = getSubstEnv `thenSmpl` \ bndr_se ->
- setSubstEnv rhs_se (simplRhs bndr bndr_se rhs)
- `thenSmpl` \ (floats, in_scope, rhs', arity) ->
- setInScope in_scope $
- completeBindNonRec (bndr `setIdArity` arity) rhs' (
- simplExprB body cont
- ) `thenSmpl` \ stuff ->
- returnSmpl (addBinds floats stuff)
+ prepareArgs (ppr var') (idType var') (get_str var') cont $ \ args' cont' ->
+ completeCall black_list in_scope var' args' cont'
where
- -- Return true only for dictionary types where the dictionary
- -- has more than one component (else we risk poking on the component
- -- of a newtype dictionary)
- is_dict bndr = opt_DictsStrict && isDictTy bndr_ty && isDataType bndr_ty
- bndr_ty = idType bndr
-\end{code}
+ get_str var = case getIdStrictness var of
+ NoStrictnessInfo -> (repeat wwLazy, False)
+ StrictnessInfo demands result_bot -> (demands, result_bot)
-completeBindNonRec
- - deals only with Ids, not TyVars
- - take an already-simplified RHS
- - always produce let bindings
+---------------------------------------------------------
+-- Preparing arguments for a call
-It does *not* attempt to do let-to-case. Why? Because they are used for
+prepareArgs :: SDoc -- Error message info
+ -> OutType -> ([Demand],Bool) -> SimplCont
+ -> ([OutExpr] -> SimplCont -> SimplM OutExprStuff)
+ -> SimplM OutExprStuff
- - top-level bindings
- (when let-to-case is impossible)
+prepareArgs pp_fun orig_fun_ty (fun_demands, result_bot) orig_cont thing_inside
+ = go [] demands orig_fun_ty orig_cont
+ where
+ not_enough_args = fun_demands `lengthExceeds` countValArgs orig_cont
+ -- "No strictness info" is signalled by an infinite list of wwLazy
+
+ demands | not_enough_args = repeat wwLazy -- Not enough args, or no strictness
+ | result_bot = fun_demands -- Enough args, and function returns bottom
+ | otherwise = fun_demands ++ repeat wwLazy -- Enough args and function does not return bottom
+ -- NB: demands is finite iff enough args and result_bot is True
- - many situations where the "rhs" is known to be a WHNF
- (so let-to-case is inappropriate).
+ -- Main game plan: loop through the arguments, simplifying
+ -- each of them in turn. We carry with us a list of demands,
+ -- and the type of the function-applied-to-earlier-args
-\begin{code}
-completeBindNonRec :: InId -- Binder
- -> OutExpr -- Simplified RHS
- -> SimplM (OutStuff a) -- Thing inside
- -> SimplM (OutStuff a)
-completeBindNonRec bndr rhs thing_inside
- | isDeadBinder bndr -- This happens; for example, the case_bndr during case of
- -- known constructor: case (a,b) of x { (p,q) -> ... }
- -- Here x isn't mentioned in the RHS, so we don't want to
- -- create the (dead) let-binding let x = (a,b) in ...
- = thing_inside
+ -- Type argument
+ go acc ds fun_ty (ApplyTo _ arg@(Type ty_arg) se cont)
+ = getInScope `thenSmpl` \ in_scope ->
+ let
+ ty_arg' = substTy (mkSubst in_scope se) ty_arg
+ res_ty = applyTy fun_ty ty_arg'
+ in
+ go (Type ty_arg' : acc) ds res_ty cont
+
+ -- Value argument
+ go acc (d:ds) fun_ty (ApplyTo _ val_arg se cont)
+ = case splitFunTy_maybe fun_ty of {
+ Nothing -> pprTrace "prepareArgs" (pp_fun $$ ppr orig_fun_ty $$ ppr orig_cont)
+ (thing_inside (reverse acc) cont) ;
+ Just (arg_ty, res_ty) ->
+ simplArg arg_ty d val_arg se (contResultType cont) $ \ arg' ->
+ go (arg':acc) ds res_ty cont }
+
+ -- We've run out of demands, which only happens for functions
+ -- we *know* now return bottom
+ -- This deals with
+ -- * case (error "hello") of { ... }
+ -- * (error "Hello") arg
+ -- * f (error "Hello") where f is strict
+ -- etc
+ go acc [] fun_ty cont = tick_case_of_error cont `thenSmpl_`
+ thing_inside (reverse acc) (discardCont cont)
+
+ -- We're run out of arguments
+ go acc ds fun_ty cont = thing_inside (reverse acc) cont
+
+-- Boring: we must only record a tick if there was an interesting
+-- continuation to discard. If not, we tick forever.
+tick_case_of_error (Stop _) = returnSmpl ()
+tick_case_of_error (CoerceIt _ (Stop _)) = returnSmpl ()
+tick_case_of_error other = tick BottomFound
- | postInlineUnconditionally bndr etad_rhs
- = tick PostInlineUnconditionally `thenSmpl_`
- extendIdSubst bndr (Done etad_rhs)
- thing_inside
+---------------------------------------------------------
+-- Dealing with a call
+
+completeCall black_list_fn in_scope var args cont
+ -- Look for rules or specialisations that match
+ -- Do this *before* trying inlining because some functions
+ -- have specialisations *and* are strict; we don't want to
+ -- inline the wrapper of the non-specialised thing... better
+ -- to call the specialised thing instead.
+ | maybeToBool maybe_rule_match
+ = tick (RuleFired rule_name) `thenSmpl_`
+ zapSubstEnv (completeApp rule_rhs rule_args cont)
+ -- See note below about zapping the substitution here
+
+ -- Look for an unfolding. There's a binding for the
+ -- thing, but perhaps we want to inline it anyway
+ | maybeToBool maybe_inline
+ = tick (UnfoldingDone var) `thenSmpl_`
+ zapSubstEnv (completeInlining var unf_template args (discardInlineCont cont))
+ -- The template is already simplified, so don't re-substitute.
+ -- This is VITAL. Consider
+ -- let x = e in
+ -- let y = \z -> ...x... in
+ -- \ x -> ...y...
+ -- We'll clone the inner \x, adding x->x' in the id_subst
+ -- Then when we inline y, we must *not* replace x by x' in
+ -- the inlined copy!!
+
+ | otherwise -- Neither rule nor inlining
+ = rebuild (mkApps (Var var) args) cont
+
+ where
+ ---------- Unfolding stuff
+ maybe_inline = callSiteInline black_listed inline_call
+ var args interesting_cont
+ Just unf_template = maybe_inline
+ interesting_cont = contIsInteresting cont
+ inline_call = contIsInline cont
+ black_listed = black_list_fn var
- | otherwise -- Note that we use etad_rhs here
- -- This gives maximum chance for a remaining binding
- -- to be zapped by the indirection zapper in OccurAnal
- = simplBinder bndr $ \ bndr' ->
- simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
- modifyInScope bndr'' $
- thing_inside `thenSmpl` \ stuff ->
- returnSmpl (addBind (NonRec bndr'' etad_rhs) stuff)
+ ---------- Specialisation stuff
+ maybe_rule_match = lookupRule in_scope var args
+ Just (rule_name, rule_rhs, rule_args) = maybe_rule_match
+
+
+-- First a special case
+-- Don't actually inline the scrutinee when we see
+-- case x of y { .... }
+-- and x has unfolding (C a b). Why not? Because
+-- we get a silly binding y = C a b. If we don't
+-- inline knownCon can directly substitute x for y instead.
+completeInlining var (Con con con_args) args (Select _ bndr alts se cont)
+ | conOkForAlt con
+ = ASSERT( null args )
+ knownCon (Var var) con con_args bndr alts se cont
+
+-- Now the normal case
+completeInlining var unfolding args cont
+ = completeApp unfolding args cont
+
+-- completeApp applies a new InExpr (from an unfolding or rule)
+-- to an *already simplified* set of arguments
+completeApp :: InExpr -- (\xs. body)
+ -> [OutExpr] -- Args; already simplified
+ -> SimplCont -- What to do with result of applicatoin
+ -> SimplM OutExprStuff
+completeApp fun args cont
+ = go fun args
where
- etad_rhs = etaCoreExpr rhs
+ zap_it = mkLamBndrZapper fun (length args)
+ cont_ty = contResultType cont
+
+ -- These equations are very similar to simplLam and simplBeta combined,
+ -- except that they deal with already-simplified arguments
+
+ -- Type argument
+ go (Lam bndr fun) (Type ty:args) = tick (BetaReduction bndr) `thenSmpl_`
+ extendSubst bndr (DoneTy ty)
+ (go fun args)
+
+ -- Value argument
+ go (Lam bndr fun) (arg:args)
+ | preInlineUnconditionally bndr && not opt_SimplNoPreInlining
+ = tick (BetaReduction bndr) `thenSmpl_`
+ tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ extendSubst bndr (DoneEx arg)
+ (go fun args)
+ | otherwise
+ = tick (BetaReduction bndr) `thenSmpl_`
+ simplBinder zapped_bndr ( \ bndr' ->
+ completeBeta zapped_bndr bndr' arg $
+ go fun args
+ )
+ where
+ zapped_bndr = zap_it bndr
--- (simplPrags old_bndr new_bndr new_rhs) does two things
--- (a) it attaches the new unfolding to new_bndr
--- (b) it grabs the SpecEnv from old_bndr, applies the current
--- substitution to it, and attaches it to new_bndr
--- The assumption is that new_bndr, which is produced by simplBinder
--- has no unfolding or specenv.
+ -- Consumed all the lambda binders or args
+ go fun args = simplExprF fun (pushArgs emptySubstEnv args cont)
-simplPrags old_bndr new_bndr new_rhs
- | isEmptySpecEnv spec_env
- = returnSmpl (bndr_w_unfolding)
- | otherwise
- = getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) ->
- let
- spec_env' = substSpecEnv ty_subst in_scope (subst_val id_subst) spec_env
- final_bndr = bndr_w_unfolding `setIdSpecialisation` spec_env'
- in
- returnSmpl final_bndr
- where
- bndr_w_unfolding = new_bndr `setIdUnfolding` mkUnfolding new_rhs
+----------- costCentreOk
+-- costCentreOk checks that it's ok to inline this thing
+-- The time it *isn't* is this:
+--
+-- f x = let y = E in
+-- scc "foo" (...y...)
+--
+-- Here y has a "current cost centre", and we can't inline it inside "foo",
+-- regardless of whether E is a WHNF or not.
+
+costCentreOk ccs_encl cc_rhs
+ = not opt_SccProfilingOn
+ || isSubsumedCCS ccs_encl -- can unfold anything into a subsumed scope
+ || not (isEmptyCC cc_rhs) -- otherwise need a cc on the unfolding
+\end{code}
- spec_env = getIdSpecialisation old_bndr
- subst_val id_subst ty_subst in_scope expr
- = substExpr ty_subst id_subst in_scope expr
-\end{code}
+
+%************************************************************************
+%* *
+\subsection{Decisions about inlining}
+%* *
+%************************************************************************
\begin{code}
preInlineUnconditionally :: InId -> Bool
-- we'd do the same for y -- aargh! So we must base this
-- pre-rhs-simplification decision solely on x's occurrences, not
-- on its rhs.
+ --
+ -- Evne RHSs labelled InlineMe aren't caught here, because
+ -- there might be no benefit from inlining at the call site.
+ -- But things labelled 'IMustBeINLINEd' *are* caught. We use this
+ -- for the trivial bindings introduced by SimplUtils.mkRhsTyLam
preInlineUnconditionally bndr
= case getInlinePragma bndr of
+ IMustBeINLINEd -> True
ICanSafelyBeINLINEd InsideLam _ -> False
ICanSafelyBeINLINEd not_in_lam True -> True -- Not inside a lambda,
-- one occurrence ==> safe!
-- we'll get another opportunity when we get to the ocurrence(s)
postInlineUnconditionally bndr rhs
- | isExported bndr
+ | isExportedId bndr
= False
| otherwise
= case getInlinePragma bndr of
IAmALoopBreaker -> False
- IMustNotBeINLINEd -> False
- IAmASpecPragmaId -> False -- Don't discard SpecPrag Ids
ICanSafelyBeINLINEd InsideLam one_branch -> exprIsTrivial rhs
- -- Don't inline even WHNFs inside lambdas; this
- -- isn't the last chance; see NOTE above.
+ -- Don't inline even WHNFs inside lambdas; doing so may
+ -- simply increase allocation when the function is called
+ -- This isn't the last chance; see NOTE above.
- ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsDupable rhs
+ ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsTrivial rhs
+ -- Was 'exprIsDupable' instead of 'exprIsTrivial' but the
+ -- decision about duplicating code is best left to callSiteInline
other -> exprIsTrivial rhs -- Duplicating is *free*
- -- NB: Even IWantToBeINLINEd and IMustBeINLINEd are ignored here
+ -- NB: Even InlineMe and IMustBeINLINEd are ignored here
-- Why? Because we don't even want to inline them into the
-- RHS of constructor arguments. See NOTE above
+ -- NB: Even IMustBeINLINEd is ignored here: if the rhs is trivial
+ -- it's best to inline it anyway. We often get a=E; b=a
+ -- from desugaring, with both a and b marked NOINLINE.
+\end{code}
+\begin{code}
inlineCase bndr scrut
- = case getInlinePragma bndr of
- -- Not expecting IAmALoopBreaker etc; this is a case binder!
-
- ICanSafelyBeINLINEd StrictOcc one_branch
- -> one_branch || exprIsDupable scrut
- -- This case is the entire reason we distinguish StrictOcc from LazyOcc
- -- We want eliminate the "case" only if we aren't going to
- -- build a thunk instead, and that's what StrictOcc finds
- -- For example:
- -- case (f x) of y { DEFAULT -> g y }
- -- Here we DO NOT WANT:
- -- g (f x)
- -- *even* if g is strict. We want to avoid constructing the
- -- thunk for (f x)! So y gets a LazyOcc.
-
- other -> exprIsTrivial scrut -- Duplication is free
- && ( isUnLiftedType (idType bndr)
- || scrut_is_evald_var -- So dropping the case won't change termination
- || isStrict (getIdDemandInfo bndr)) -- It's going to get evaluated later, so again
- -- termination doesn't change
+ = exprIsTrivial scrut -- Duplication is free
+ && ( isUnLiftedType (idType bndr)
+ || scrut_is_evald_var -- So dropping the case won't change termination
+ || isStrict (getIdDemandInfo bndr) -- It's going to get evaluated later, so again
+ -- termination doesn't change
+ || not opt_SimplPedanticBottoms) -- Or we don't care!
where
-- Check whether or not scrut is known to be evaluted
-- It's not going to be a visible value (else the previous
other -> False
\end{code}
-okToInline is used at call sites, so it is a bit more generous.
-It's a very important function that embodies lots of heuristics.
-
-\begin{code}
-okToInline :: SwitchChecker
- -> InScopeEnv
- -> Id -- The Id
- -> FormSummary -- The thing is WHNF or bottom;
- -> UnfoldingGuidance
- -> SimplCont
- -> Bool -- True <=> inline it
-
--- A non-WHNF can be inlined if it doesn't occur inside a lambda,
--- and occurs exactly once or
--- occurs once in each branch of a case and is small
---
--- If the thing is in WHNF, there's no danger of duplicating work,
--- so we can inline if it occurs once, or is small
-
-okToInline sw_chkr in_scope id form guidance cont
- =
-#ifdef DEBUG
- if opt_D_dump_inlinings then
- pprTrace "Considering inlining"
- (ppr id <+> vcat [text "inline prag:" <+> ppr inline_prag,
- text "whnf" <+> ppr whnf,
- text "small enough" <+> ppr small_enough,
- text "some benefit" <+> ppr some_benefit,
- text "arg evals" <+> ppr arg_evals,
- text "result scrut" <+> ppr result_scrut,
- text "ANSWER =" <+> if result then text "YES" else text "NO"])
- result
- else
-#endif
- result
- where
- result =
- case inline_prag of
- IAmDead -> pprTrace "okToInline: dead" (ppr id) False
- IAmASpecPragmaId -> False
- IMustNotBeINLINEd -> False
- IAmALoopBreaker -> False
- IMustBeINLINEd -> True -- If "essential_unfoldings_only" is true we do no inlinings at all,
- -- EXCEPT for things that absolutely have to be done
- -- (see comments with idMustBeINLINEd)
- IWantToBeINLINEd -> inlinings_enabled
- ICanSafelyBeINLINEd inside_lam one_branch
- -> inlinings_enabled && (unfold_always || consider_single inside_lam one_branch)
- NoInlinePragInfo -> inlinings_enabled && (unfold_always || consider_multi)
-
- inlinings_enabled = not (switchIsOn sw_chkr EssentialUnfoldingsOnly)
- unfold_always = unfoldAlways guidance
-
- -- Consider benefit for ICanSafelyBeINLINEd
- consider_single inside_lam one_branch
- = (small_enough || one_branch) && some_benefit && (whnf || not_inside_lam)
- where
- not_inside_lam = case inside_lam of {InsideLam -> False; other -> True}
-
- -- Consider benefit for NoInlinePragInfo
- consider_multi = whnf && small_enough && some_benefit
- -- We could consider using exprIsCheap here,
- -- as in postInlineUnconditionally, but unlike the latter we wouldn't
- -- necessarily eliminate a thunk; and the "form" doesn't tell
- -- us that.
-
- inline_prag = getInlinePragma id
- whnf = whnfOrBottom form
- small_enough = smallEnoughToInline id arg_evals result_scrut guidance
- (arg_evals, result_scrut) = get_evals cont
-
- -- some_benefit checks that *something* interesting happens to
- -- the variable after it's inlined.
- some_benefit = contIsInteresting cont
-
- -- Finding out whether the args are evaluated. This isn't completely easy
- -- because the args are not yet simplified, so we have to peek into them.
- get_evals (ApplyTo _ arg (te,ve) cont)
- | isValArg arg = case get_evals cont of
- (args, res) -> (get_arg_eval arg ve : args, res)
- | otherwise = get_evals cont
-
- get_evals (Select _ _ _ _ _) = ([], True)
- get_evals other = ([], False)
-
- get_arg_eval (Con con _) ve = isWHNFCon con
- get_arg_eval (Var v) ve = case lookupVarEnv ve v of
- Just (SubstMe e' _ ve') -> get_arg_eval e' ve'
- Just (Done (Con con _)) -> isWHNFCon con
- Just (Done (Var v')) -> get_var_eval v'
- Just (Done other) -> False
- Nothing -> get_var_eval v
- get_arg_eval other ve = False
-
- get_var_eval v = case lookupVarSet in_scope v of
- Just v' -> isEvaldUnfolding (getIdUnfolding v')
- Nothing -> isEvaldUnfolding (getIdUnfolding v)
-
-
-contIsInteresting :: SimplCont -> Bool
-contIsInteresting Stop = False
-contIsInteresting (ArgOf _ _ _) = False
-contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
-contIsInteresting (CoerceIt _ _ _ cont) = contIsInteresting cont
-
--- See notes below on why a case with only a DEFAULT case is not intersting
--- contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False
-
-contIsInteresting _ = True
-\end{code}
-
-Comment about some_benefit above
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-We want to avoid inlining an expression where there can't possibly be
-any gain, such as in an argument position. Hence, if the continuation
-is interesting (eg. a case scrutinee, application etc.) then we
-inline, otherwise we don't.
-
-Previously some_benefit used to return True only if the variable was
-applied to some value arguments. This didn't work:
-
- let x = _coerce_ (T Int) Int (I# 3) in
- case _coerce_ Int (T Int) x of
- I# y -> ....
-
-we want to inline x, but can't see that it's a constructor in a case
-scrutinee position, and some_benefit is False.
-
-Another example:
-
-dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
-
-.... case dMonadST _@_ x0 of (a,b,c) -> ....
-
-we'd really like to inline dMonadST here, but we *don't* want to
-inline if the case expression is just
-
- case x of y { DEFAULT -> ... }
-
-since we can just eliminate this case instead (x is in WHNF). Similar
-applies when x is bound to a lambda expression. Hence
-contIsInteresting looks for case expressions with just a single
-default case.
%************************************************************************
\begin{code}
-------------------------------------------------------------------
-rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
-
-rebuild expr cont
- = tick LeavesExamined `thenSmpl_`
- case expr of
- Var v -> case getIdStrictness v of
- NoStrictnessInfo -> do_rebuild expr cont
- StrictnessInfo demands result_bot -> ASSERT( not (null demands) || result_bot )
- -- If this happened we'd get an infinite loop
- rebuild_strict demands result_bot expr (idType v) cont
- other -> do_rebuild expr cont
-
+-- Finish rebuilding
rebuild_done expr
- = getInScope `thenSmpl` \ in_scope ->
+ = getInScope `thenSmpl` \ in_scope ->
returnSmpl ([], (in_scope, expr))
---------------------------------------------------------
--- Stop continuation
-
-do_rebuild expr Stop = rebuild_done expr
+rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
+-- Stop continuation
+rebuild expr (Stop _) = rebuild_done expr
----------------------------------------------------------
-- ArgOf continuation
+rebuild expr (ArgOf _ _ cont_fn) = cont_fn expr
-do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr
-
----------------------------------------------------------
-- ApplyTo continuation
+rebuild expr cont@(ApplyTo _ arg se cont')
+ = setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' ->
+ rebuild (App expr arg') cont'
-do_rebuild expr cont@(ApplyTo _ arg se cont')
- = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
- do_rebuild (App expr arg') cont'
-
-
----------------------------------------------------------
-- Coerce continuation
+rebuild expr (CoerceIt to_ty cont)
+ = rebuild (mkCoerce to_ty expr) cont
-do_rebuild expr (CoerceIt _ to_ty se cont)
- = setSubstEnv se $
- simplType to_ty `thenSmpl` \ to_ty' ->
- do_rebuild (mk_coerce to_ty' expr) cont
-
+-- Inline continuation
+rebuild expr (InlinePlease cont)
+ = rebuild (Note InlineCall expr) cont
----------------------------------------------------------
-- Case of known constructor or literal
-
-do_rebuild expr@(Con con args) cont@(Select _ _ _ _ _)
+rebuild expr@(Con con args) (Select _ bndr alts se cont)
| conOkForAlt con -- Knocks out PrimOps and NoRepLits
- = knownCon expr con args cont
-
-
----------------------------------------------------------
+ = knownCon expr con args bndr alts se cont
-- Case of other value (e.g. a partial application or lambda)
-- Turn it back into a let
-
-do_rebuild expr (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
- | case mkFormSummary expr of { ValueForm -> True; other -> False }
+rebuild scrut (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
+ | isUnLiftedType (idType bndr) && exprOkForSpeculation scrut
+ || exprIsWHNF scrut
= ASSERT( null bs && null alts )
- tick Case2Let `thenSmpl_`
- setSubstEnv se (
- completeBindNonRec bndr expr $
- simplExprB rhs cont
- )
+ setSubstEnv se $
+ simplBinder bndr $ \ bndr' ->
+ completeBinding bndr bndr' scrut $
+ simplExprF rhs cont
---------------------------------------------------------
-- The other Select cases
-do_rebuild scrut (Select _ bndr alts se cont)
- = getSwitchChecker `thenSmpl` \ chkr ->
-
- if all (cheapEqExpr rhs1) other_rhss
- && inlineCase bndr scrut
- && all binders_unused alts
- && switchIsOn chkr SimplDoCaseElim
- then
- -- Get rid of the case altogether
+rebuild scrut (Select _ bndr alts se cont)
+ | all (cheapEqExpr rhs1) other_rhss
+ && inlineCase bndr scrut
+ && all binders_unused alts
+ && opt_SimplDoCaseElim
+ = -- Get rid of the case altogether
-- See the extensive notes on case-elimination below
-- Remember to bind the binder though!
- tick CaseElim `thenSmpl_`
+ tick (CaseElim bndr) `thenSmpl_`
setSubstEnv se (
- extendIdSubst bndr (Done scrut) $
- simplExprB rhs1 cont
+ extendSubst bndr (DoneEx scrut) $
+ simplExprF rhs1 cont
)
-
- else
- rebuild_case chkr scrut bndr alts se cont
+ | otherwise
+ = rebuild_case scrut bndr alts se cont
where
(rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts]
binders_unused (_, bndrs, _) = all isDeadBinder bndrs
If so, then we can replace the case with one of the rhss.
-\begin{code}
----------------------------------------------------------
--- Rebuiling a function with strictness info
--- This just a version of do_rebuild, enhanced with info about
--- the strictness of the thing being rebuilt.
-
-rebuild_strict :: [Demand] -> Bool -- Stricness info
- -> OutExpr -> OutType -- Function and type
- -> SimplCont -- Continuation
- -> SimplM OutExprStuff
-
-rebuild_strict [] True fun fun_ty cont = rebuild_bot fun fun_ty cont
-rebuild_strict [] False fun fun_ty cont = do_rebuild fun cont
-
-rebuild_strict ds result_bot fun fun_ty (CoerceIt _ to_ty se cont)
- = setSubstEnv se $
- simplType to_ty `thenSmpl` \ to_ty' ->
- rebuild_strict ds result_bot (mk_coerce to_ty' fun) to_ty' cont
-
-rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont)
- -- Type arg; don't consume a demand
- = setSubstEnv se (simplType ty_arg) `thenSmpl` \ ty_arg' ->
- rebuild_strict ds result_bot (App fun (Type ty_arg'))
- (applyTy fun_ty ty_arg') cont
-
-rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont)
- | isStrict d || isUnLiftedType arg_ty
- -- Strict value argument
- = getInScope `thenSmpl` \ in_scope ->
- let
- cont_ty = contResultType in_scope res_ty cont
- in
- setSubstEnv se (simplExprB val_arg (ArgOf NoDup cont_fn cont_ty))
-
- | otherwise -- Lazy value argument
- = setSubstEnv se (simplArg val_arg) `thenSmpl` \ val_arg' ->
- cont_fn val_arg'
-
- where
- Just (arg_ty, res_ty) = splitFunTy_maybe fun_ty
- cont_fn arg' = rebuild_strict ds result_bot
- (App fun arg') res_ty
- cont
-
-rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont
-
----------------------------------------------------------
--- Dealing with
--- * case (error "hello") of { ... }
--- * (error "Hello") arg
--- * f (error "Hello") where f is strict
--- etc
-
-rebuild_bot expr expr_ty Stop -- No coerce needed
- = rebuild_done expr
-
-rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop) -- Don't "tick" on this,
- -- else simplifier never stops
- = setSubstEnv se $
- simplType to_ty `thenSmpl` \ to_ty' ->
- rebuild_done (mkNote (Coerce to_ty' expr_ty) expr)
-
-rebuild_bot expr expr_ty cont -- Abandon the (strict) continuation,
- -- and just return expr
- = tick CaseOfError `thenSmpl_`
- getInScope `thenSmpl` \ in_scope ->
- let
- result_ty = contResultType in_scope expr_ty cont
- in
- rebuild_done (mkNote (Coerce result_ty expr_ty) expr)
-
-mk_coerce to_ty (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty from_ty) expr
-mk_coerce to_ty expr = Note (Coerce to_ty (coreExprType expr)) expr
-\end{code}
-
Blob of helper functions for the "case-of-something-else" situation.
\begin{code}
---------------------------------------------------------
-- Case of something else
-rebuild_case sw_chkr scrut case_bndr alts se cont
+rebuild_case scrut case_bndr alts se cont
= -- Prepare case alternatives
- prepareCaseAlts (splitTyConApp_maybe (idType case_bndr))
+ prepareCaseAlts case_bndr (splitTyConApp_maybe (idType case_bndr))
scrut_cons alts `thenSmpl` \ better_alts ->
-- Set the new subst-env in place (before dealing with the case binder)
simplAlts zap_occ_info scrut_cons
case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
- mkCase sw_chkr scrut case_bndr'' alts' `thenSmpl` \ case_expr ->
+ mkCase scrut case_bndr'' alts' `thenSmpl` \ case_expr ->
rebuild_done case_expr
where
-- scrut_cons tells what constructors the scrutinee can't possibly match
other -> []
-knownCon expr con args (Select _ bndr alts se cont)
- = tick KnownBranch `thenSmpl_`
- setSubstEnv se (
+knownCon expr con args bndr alts se cont
+ = tick (KnownBranch bndr) `thenSmpl_`
+ setSubstEnv se (
+ simplBinder bndr $ \ bndr' ->
case findAlt con alts of
(DEFAULT, bs, rhs) -> ASSERT( null bs )
- completeBindNonRec bndr expr $
- simplExprB rhs cont
+ completeBinding bndr bndr' expr $
+ -- Don't use completeBeta here. The expr might be
+ -- an unboxed literal, like 3, or a variable
+ -- whose unfolding is an unboxed literal... and
+ -- completeBeta will just construct another case
+ -- expression!
+ simplExprF rhs cont
(Literal lit, bs, rhs) -> ASSERT( null bs )
- extendIdSubst bndr (Done expr) $
+ extendSubst bndr (DoneEx expr) $
-- Unconditionally substitute, because expr must
-- be a variable or a literal. It can't be a
-- NoRep literal because they don't occur in
-- case patterns.
- simplExprB rhs cont
+ simplExprF rhs cont
- (DataCon dc, bs, rhs) -> completeBindNonRec bndr expr $
- extend bs real_args $
- simplExprB rhs cont
+ (DataCon dc, bs, rhs) -> ASSERT( length bs == length real_args )
+ completeBinding bndr bndr' expr $
+ -- See note above
+ extendSubstList bs (map mk real_args) $
+ simplExprF rhs cont
where
- real_args = drop (dataConNumInstArgs dc) args
+ real_args = drop (dataConNumInstArgs dc) args
+ mk (Type ty) = DoneTy ty
+ mk other = DoneEx other
)
- where
- extend [] [] thing_inside = thing_inside
- extend (b:bs) (arg:args) thing_inside = extendIdSubst b (Done arg) $
- extend bs args thing_inside
\end{code}
\begin{code}
Here, b and p are dead. But when we move the argment inside the first
case RHS, and eliminate the second case, we get
- case x or { (a,b) -> a b
+ case x or { (a,b) -> a b }
Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
happened. Hence the zap_occ_info function returned by substForVarScrut
when rhs also scrutinises x or e.
\begin{code}
-prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts
+prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts
| isDataTyCon tycon
= case (findDefault filtered_alts, missing_cons) of
((alts_no_deflt, Just rhs), [data_con]) -- Just one missing constructor!
- -> tick FillInCaseDefault `thenSmpl_`
+ -> tick (FillInCaseDefault bndr) `thenSmpl_`
let
(_,_,ex_tyvars,_,_,_) = dataConSig data_con
in
[data_con | (DataCon data_con, _, _) <- filtered_alts]
-- The default case
-prepareCaseAlts _ scrut_cons alts
+prepareCaseAlts _ _ scrut_cons alts
= returnSmpl alts -- Functions
= -- In the default case we record the constructors that the
-- case-binder *can't* be.
-- We take advantage of any OtherCon info in the case scrutinee
- modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $
- simplExpr rhs cont' `thenSmpl` \ rhs' ->
+ modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $
+ simplExprC rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (DEFAULT, [], rhs')
simpl_alt (con, vs, rhs)
con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs')
in
modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app) $
- simplExpr rhs cont' `thenSmpl` \ rhs' ->
+ simplExprC rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (con, vs', rhs')
-- We really must record that b is already evaluated so that we don't
-- go and re-evaluate it when constructing the result.
- add_evals (DataCon dc) vs = cat_evals vs (dataConStrictMarks dc)
+ add_evals (DataCon dc) vs = cat_evals vs (dataConRepStrictness dc)
add_evals other_con vs = vs
cat_evals [] [] = []
cat_evals (v:vs) (str:strs)
- | isTyVar v = v : cat_evals vs (str:strs)
- | otherwise =
- case str of
- MarkedStrict ->
- (zap_occ_info v `setIdUnfolding` OtherCon [])
- : cat_evals vs strs
- MarkedUnboxed con _ ->
- cat_evals (v:vs) (dataConStrictMarks con ++ strs)
- NotMarkedStrict -> zap_occ_info v : cat_evals vs strs
+ | isTyVar v = v : cat_evals vs (str:strs)
+ | isStrict str = (v' `setIdUnfolding` OtherCon []) : cat_evals vs strs
+ | otherwise = v' : cat_evals vs strs
+ where
+ v' = zap_occ_info v
\end{code}
-
%************************************************************************
%* *
\subsection{Duplicating continuations}
| contIsDupable cont
= thing_inside cont
-mkDupableCont _ (CoerceIt _ ty se cont) thing_inside
+mkDupableCont _ (CoerceIt ty cont) thing_inside
= mkDupableCont ty cont $ \ cont' ->
- thing_inside (CoerceIt OkToDup ty se cont')
+ thing_inside (CoerceIt ty cont')
-mkDupableCont join_arg_ty (ArgOf _ cont_fn res_ty) thing_inside
+mkDupableCont ty (InlinePlease cont) thing_inside
+ = mkDupableCont ty cont $ \ cont' ->
+ thing_inside (InlinePlease cont')
+
+mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside
= -- Build the RHS of the join point
simplType join_arg_ty `thenSmpl` \ join_arg_ty' ->
newId join_arg_ty' ( \ arg_id ->
getSwitchChecker `thenSmpl` \ chkr ->
cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) ->
- returnSmpl (Lam arg_id (mkLetBinds binds rhs))
+ returnSmpl (Lam arg_id (mkLets binds rhs))
) `thenSmpl` \ join_rhs ->
-- Build the join Id and continuation
newId (coreExprType join_rhs) $ \ join_id ->
let
- new_cont = ArgOf OkToDup
+ new_cont = ArgOf OkToDup cont_ty
(\arg' -> rebuild_done (App (Var join_id) arg'))
- res_ty
in
-- Do the thing inside
mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
= mkDupableCont (funResultTy ty) cont $ \ cont' ->
- setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
+ setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' ->
if exprIsDupable arg' then
thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
else
returnSmpl (addBind (NonRec bndr arg') res)
mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
- = tick CaseOfCase `thenSmpl_` (
- setSubstEnv se (
- simplBinder case_bndr $ \ case_bndr' ->
- prepareCaseCont alts cont $ \ cont' ->
- mapAndUnzipSmpl (mkDupableAlt case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') ->
- returnSmpl (concat alt_binds_s, (case_bndr', alts'))
- ) `thenSmpl` \ (alt_binds, (case_bndr', alts')) ->
-
- extendInScopes [b | NonRec b _ <- alt_binds] $
- thing_inside (Select OkToDup case_bndr' alts' emptySubstEnv Stop) `thenSmpl` \ res ->
+ = tick (CaseOfCase case_bndr) `thenSmpl_`
+ setSubstEnv se (
+ simplBinder case_bndr $ \ case_bndr' ->
+ prepareCaseCont alts cont $ \ cont' ->
+ mapAndUnzipSmpl (mkDupableAlt case_bndr case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') ->
+ returnSmpl (concat alt_binds_s, alts')
+ ) `thenSmpl` \ (alt_binds, alts') ->
+
+ extendInScopes [b | NonRec b _ <- alt_binds] $
+
+ -- NB that the new alternatives, alts', are still InAlts, using the original
+ -- binders. That means we can keep the case_bndr intact. This is important
+ -- because another case-of-case might strike, and so we want to keep the
+ -- info that the case_bndr is dead (if it is, which is often the case).
+ -- This is VITAL when the type of case_bndr is an unboxed pair (often the
+ -- case in I/O rich code. We aren't allowed a lambda bound
+ -- arg of unboxed tuple type, and indeed such a case_bndr is always dead
+ thing_inside (Select OkToDup case_bndr alts' se (Stop (contResultType cont))) `thenSmpl` \ res ->
+
returnSmpl (addBinds alt_binds res)
- )
-mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM (OutStuff CoreAlt)
-mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs)
- = simplBinders bndrs $ \ bndrs' ->
- simplExpr rhs cont `thenSmpl` \ rhs' ->
- if exprIsDupable rhs' then
- -- It's small, so don't bother to let-bind it
- returnSmpl ([], (con, bndrs', rhs'))
- else
- -- It's big, so let-bind it
+
+mkDupableAlt :: InId -> OutId -> SimplCont -> InAlt -> SimplM (OutStuff InAlt)
+mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs)
+ = -- Not worth checking whether the rhs is small; the
+ -- inliner will inline it if so.
+ simplBinders bndrs $ \ bndrs' ->
+ simplExprC rhs cont `thenSmpl` \ rhs' ->
let
rhs_ty' = coreExprType rhs'
- used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
+ (used_bndrs, used_bndrs')
+ = unzip [pr | pr@(bndr,bndr') <- zip (case_bndr : bndrs)
+ (case_bndr' : bndrs'),
+ not (isDeadBinder bndr)]
+ -- The new binders have lost their occurrence info,
+ -- so we have to extract it from the old ones
in
- ( if null used_bndrs' && isUnLiftedType rhs_ty'
- then newId realWorldStatePrimTy $ \ rw_id ->
- returnSmpl ([rw_id], [varToCoreExpr realWorldPrimId])
- else
- returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
- )
- `thenSmpl` \ (final_bndrs', final_args) ->
-
+ ( if null used_bndrs'
-- If we try to lift a primitive-typed something out
-- for let-binding-purposes, we will *caseify* it (!),
-- with potentially-disastrous strictness results. So
-- case_bndr to all the join points if it's used in *any* RHS,
-- because we don't know its usage in each RHS separately
+ -- We used to say "&& isUnLiftedType rhs_ty'" here, but now
+ -- we make the join point into a function whenever used_bndrs'
+ -- is empty. This makes the join-point more CPR friendly.
+ -- Consider: let j = if .. then I# 3 else I# 4
+ -- in case .. of { A -> j; B -> j; C -> ... }
+ --
+ -- Now CPR should not w/w j because it's a thunk, so
+ -- that means that the enclosing function can't w/w either,
+ -- which is a BIG LOSE. This actually happens in practice
+ then newId realWorldStatePrimTy $ \ rw_id ->
+ returnSmpl ([rw_id], [Var realWorldPrimId])
+ else
+ returnSmpl (used_bndrs', map varToCoreExpr used_bndrs)
+ )
+ `thenSmpl` \ (final_bndrs', final_args) ->
+
newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
returnSmpl ([NonRec join_bndr (mkLams final_bndrs' rhs')],
- (con, bndrs', mkApps (Var join_bndr) final_args))
+ (con, bndrs, mkApps (Var join_bndr) final_args))
\end{code}
import StgSyn
import Bag ( Bag, emptyBag, unionBags, unitBag, snocBag, bagToList )
-import Id ( mkUserId, idType, setIdArity, Id )
+import Id ( mkVanillaId, idType, setIdArity, Id )
import VarSet
import VarEnv
import IdInfo ( exactArity )
-> LiftM Id
newSupercombinator ty arity mod ci us idenv
- = mkUserId (mkTopName uniq mod SLIT("_ll")) ty
+ = mkVanillaId (mkTopName uniq mod SLIT("_ll")) ty
`setIdArity` exactArity arity
-- ToDo: rm the setIdArity? Just let subsequent stg-saturation pass do it?
where
import CmdLineOpts ( opt_SccGroup,
opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
- opt_DoStgLinting,
+ opt_DoStgLinting, opt_D_dump_stg,
StgToDo(..)
)
import Id ( Id )
import Module ( Module, moduleString )
import VarEnv
-import ErrUtils ( doIfSet )
+import ErrUtils ( doIfSet, dumpIfSet )
import UniqSupply ( splitUniqSupply, UniqSupply )
import IO ( hPutStr, stderr )
import Outputable
srt_binds = computeSRTs annotated_binds
in
+ dumpIfSet opt_D_dump_stg "STG syntax:"
+ (pprStgBindingsWithSRTs srt_binds) >>
+
return (srt_binds, cost_centres)
}
where
let
-- determine whether the default binder is dead or not
bndr'= if (bndr `elementOfFVInfo` alts_fvs)
- then bndr `modifyIdInfo` (setInlinePragInfo NoInlinePragInfo)
- else bndr `modifyIdInfo` (setInlinePragInfo IAmDead)
+ then modifyIdInfo (`setInlinePragInfo` NoInlinePragInfo) bndr
+ else modifyIdInfo (`setInlinePragInfo` IAmDead) bndr
-- don't consider the default binder as being 'live in alts',
-- since this is from the point of view of the case expr, where
StgCase scrut2 live_in_whole_case live_in_alts bndr' srt alts2,
(scrut_fvs `unionFVInfo` alts_fvs)
`minusFVBinders` [bndr],
- (alts_escs `unionVarSet` (getFVSet scrut_fvs))
- `minusVarSet` unitVarSet bndr
-
- ))
+ (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
+ -- You might think we should have scrut_escs, not (getFVSet scrut_fvs),
+ -- but actually we can't call, and then return from, a let-no-escape thing.
+ )
+ )
where
vars_alts (StgAlgAlts ty alts deflt)
= mapAndUnzip3Lne vars_alg_alt alts
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[CoreRules]{Transformation rules}
+
+\begin{code}
+module Rules (
+ RuleBase, prepareRuleBase, lookupRule,
+ addIdSpecialisations,
+ ProtoCoreRule(..), pprProtoCoreRule, orphanRule
+ ) where
+
+#include "HsVersions.h"
+
+import CoreSyn -- All of it
+import OccurAnal ( occurAnalyseExpr, tagBinders, UsageDetails )
+import BinderInfo ( markMany )
+import CoreFVs ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars )
+import CoreUnfold ( Unfolding(..) )
+import CoreUtils ( whnfOrBottom, eqExpr )
+import PprCore ( pprCoreRule )
+import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst,
+ mkSubst, substEnv, setSubstEnv,
+ unBindSubst, bindSubstList, unBindSubstList,
+ )
+import Id ( Id, getIdUnfolding,
+ getIdSpecialisation, setIdSpecialisation,
+ setIdNoDiscard, maybeModifyIdInfo, modifyIdInfo
+ )
+import IdInfo ( zapLamIdInfo, setSpecInfo, specInfo )
+import Name ( Name, isLocallyDefined )
+import Var ( isTyVar, isId )
+import VarSet
+import VarEnv
+import Type ( mkTyVarTy, getTyVar_maybe )
+import qualified Unify ( match )
+import CmdLineOpts ( opt_D_dump_simpl, opt_D_verbose_core2core )
+
+import UniqFM
+import ErrUtils ( dumpIfSet )
+import Outputable
+import Maybes ( maybeToBool )
+import List ( partition )
+import Util ( sortLt )
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
+%* *
+%************************************************************************
+
+A @CoreRule@ holds details of one rule for an @Id@, which
+includes its specialisations.
+
+For example, if a rule for @f@ contains the mapping:
+\begin{verbatim}
+ forall a b d. [Type (List a), Type b, Var d] ===> f' a b
+\end{verbatim}
+then when we find an application of f to matching types, we simply replace
+it by the matching RHS:
+\begin{verbatim}
+ f (List Int) Bool dict ===> f' Int Bool
+\end{verbatim}
+All the stuff about how many dictionaries to discard, and what types
+to apply the specialised function to, are handled by the fact that the
+Rule contains a template for the result of the specialisation.
+
+There is one more exciting case, which is dealt with in exactly the same
+way. If the specialised value is unboxed then it is lifted at its
+definition site and unlifted at its uses. For example:
+
+ pi :: forall a. Num a => a
+
+might have a specialisation
+
+ [Int#] ===> (case pi' of Lift pi# -> pi#)
+
+where pi' :: Lift Int# is the specialised version of pi.
+
+
+%************************************************************************
+%* *
+\subsection{Matching}
+%* *
+%************************************************************************
+
+\begin{code}
+matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+-- See comments on matchRule
+matchRules in_scope [] args = Nothing
+matchRules in_scope (rule:rules) args
+ = case matchRule in_scope rule args of
+ Just result -> Just result
+ Nothing -> matchRules in_scope rules args
+
+
+matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+
+-- If (matchRule rule args) returns Just (name,rhs,args')
+-- then (f args) matches the rule, and the corresponding
+-- rewritten RHS is (rhs args').
+--
+-- The bndrs and rhs is occurrence-analysed
+--
+-- Example
+--
+-- The rule
+-- forall f g x. map f (map g x) ==> map (f . g) x
+-- is stored
+-- CoreRule "map/map"
+-- [f,g,x] -- tpl_vars
+-- [f,map g x] -- tpl_args
+-- map (f.g) x) -- rhs
+--
+-- Then the call: matchRule the_rule [e1,map e2 e3]
+-- = Just ("map/map", \f,g,x -> rhs, [e1,e2,e3])
+--
+-- Any 'surplus' arguments in the input are simply put on the end
+-- of the output.
+--
+-- ASSUMPTION (A):
+-- No variable free in the template is bound in the target
+
+matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
+ = go tpl_args args (mkSubst in_scope emptySubstEnv)
+ where
+ tpl_var_set = mkVarSet tpl_vars
+
+ -----------------------
+ -- Do the business
+ go (tpl_arg:tpl_args) (arg:args) subst = match tpl_arg arg tpl_var_set (go tpl_args args) subst
+
+ -- Two easy ways to terminate
+ go [] [] subst = Just (rn, mkLams tpl_vars rhs, mk_result_args subst tpl_vars)
+ go [] args subst = Just (rn, mkLams tpl_vars rhs, mk_result_args subst tpl_vars ++ args)
+
+ -- One tiresome way to terminate: check for excess unmatched
+ -- template arguments
+ go tpl_args [] subst
+ = case eta_complete tpl_args (mkVarSet leftovers) of
+ Just leftovers' -> Just (rn, mkLams done (mkLams leftovers' rhs),
+ mk_result_args subst done)
+ Nothing -> Nothing -- Failure
+ where
+ (done, leftovers) = partition (\v -> maybeToBool (lookupSubstEnv subst_env v))
+ (map zapOccInfo tpl_vars)
+ -- Zap the occ info
+ subst_env = substEnv subst
+
+ -----------------------
+ eta_complete [] vars = ASSERT( isEmptyVarSet vars )
+ Just []
+ eta_complete (Type ty:tpl_args) vars
+ = case getTyVar_maybe ty of
+ Just tv | tv `elemVarSet` vars
+ -> case eta_complete tpl_args (vars `delVarSet` tv) of
+ Just vars' -> Just (tv:vars')
+ Nothing -> Nothing
+ other -> Nothing
+
+ eta_complete (Var v:tpl_args) vars
+ | v `elemVarSet` vars
+ = case eta_complete tpl_args (vars `delVarSet` v) of
+ Just vars' -> Just (v:vars')
+ Nothing -> Nothing
+
+ eta_complete other vars = Nothing
+
+ -----------------------
+ mk_result_args subst vs = map go vs
+ where
+ senv = substEnv subst
+ go v = case lookupSubstEnv senv v of
+ Just (DoneEx ex) -> ex
+ Just (DoneTy ty) -> Type ty
+ -- Substitution should bind them all!
+
+zapOccInfo bndr | isTyVar bndr = bndr
+ | otherwise = maybeModifyIdInfo zapLamIdInfo bndr
+\end{code}
+
+\begin{code}
+type Matcher result = IdOrTyVarSet -- Template variables
+ -> (Subst -> Maybe result) -- Continuation if success
+ -> Subst -> Maybe result -- Substitution so far -> result
+-- The *SubstEnv* in these Substs apply to the TEMPLATE only
+
+-- The *InScopeSet* in these Substs gives a superset of the free vars
+-- in the term being matched. This set can get augmented, for example
+-- when matching against a lambda:
+-- (\x.M) ~ N iff M ~ N x
+-- but we must clone x if it's already free in N
+
+match :: CoreExpr -- Template
+ -> CoreExpr -- Target
+ -> Matcher result
+
+match_fail = Nothing
+
+match (Var v1) e2 tpl_vars kont subst
+ = case lookupSubst subst v1 of
+ Nothing | v1 `elemVarSet` tpl_vars -> kont (extendSubst subst v1 (DoneEx e2))
+ -- v1 is a template variables
+
+ | eqExpr (Var v1) e2 -> kont subst
+ -- v1 is not a template variable, so it must be a global constant
+
+ Just (DoneEx e2') | eqExpr e2' e2 -> kont subst
+
+ other -> match_fail
+
+match (Con c1 es1) (Con c2 es2) tpl_vars kont subst
+ | c1 == c2
+ = matches es1 es2 tpl_vars kont subst
+
+match (App f1 a1) (App f2 a2) tpl_vars kont subst
+ = match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst
+
+match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst
+ = bind [x1] [x2] (match e1 e2) tpl_vars kont subst
+
+-- This rule does eta expansion
+-- (\x.M) ~ N iff M ~ N x
+-- We must clone the binder in case it's already in scope in N
+match (Lam x1 e1) e2 tpl_vars kont subst
+ = match e1 (App e2 (mkVarArg x1')) tpl_vars kont' subst'
+ where
+ (subst', x1') = substBndr subst x1
+ kont' subst = kont (unBindSubst subst x1 x1')
+
+-- Eta expansion the other way
+-- M ~ (\y.N) iff \y.M y ~ \y.N
+-- iff M y ~ N
+-- Remembering that by (A), y can't be free in M, we get this
+match e1 (Lam x2 e2) tpl_vars kont subst
+ = match (App e1 (mkVarArg x2)) e2 tpl_vars kont subst
+
+match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
+ = match e1 e2 tpl_vars case_kont subst
+ where
+ case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLt lt_alt alts2))
+ tpl_vars kont subst
+
+match (Type ty1) (Type ty2) tpl_vars kont subst
+ = match_ty ty1 ty2 tpl_vars kont subst
+
+match (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
+ tpl_vars kont subst
+ = (match_ty to1 to2 tpl_vars $
+ match_ty from1 from2 tpl_vars $
+ match e1 e2 tpl_vars kont) subst
+
+
+{- I don't buy this let-rule any more
+ The let rule fails on matching
+ forall f,x,xs. f (x:xs)
+ against
+ f (let y = e in (y:[]))
+ because we just get x->y, which is bogus.
+
+-- This is an interesting rule: we simply ignore lets in the
+-- term being matched against! The unfolding inside it is (by assumption)
+-- already inside any occurrences of the bound variables, so we'll expand
+-- them when we encounter them. Meanwhile, we can't get false matches because
+-- (also by assumption) the term being matched has no shadowing.
+match e1 (Let bind e2) tpl_vars kont subst
+ = match e1 e2 tpl_vars kont subst
+-}
+
+-- Here is another important rule: if the term being matched is a
+-- variable, we expand it so long as its unfolding is a WHNF
+-- (Its occurrence information is not necessarily up to date,
+-- so we don't use it.)
+match e1 (Var v2) tpl_vars kont subst
+ = case getIdUnfolding v2 of
+ CoreUnfolding form guidance unfolding
+ | whnfOrBottom form
+ -> match e1 unfolding tpl_vars kont subst
+
+ other -> match_fail
+
+-- We can't cope with lets in the template
+
+match e1 e2 tpl_vars kont subst = match_fail
+
+
+------------------------------------------
+match_alts [] [] tpl_vars kont subst
+ = kont subst
+match_alts ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) tpl_vars kont subst
+ | c1 == c2
+ = bind vs1 vs2 (match r1 r2) tpl_vars
+ (match_alts alts1 alts2 tpl_vars kont)
+ subst
+match_alts alts1 alts2 tpl_vars kont subst = match_fail
+
+lt_alt (con1, _, _) (con2, _, _) = con1 < con2
+
+----------------------------------------
+bind :: [CoreBndr] -- Template binders
+ -> [CoreBndr] -- Target binders
+ -> Matcher result
+ -> Matcher result
+-- This makes uses of assumption (A) above. For example,
+-- this would fail:
+-- Template: (\x.y) (y is free)
+-- Target : (\y.y) (y is bound)
+-- We rename x to y in the template... but then erroneously
+-- match y against y. But this can't happen because of (A)
+bind vs1 vs2 matcher tpl_vars kont subst
+ = ASSERT( all not_in_subst vs1)
+ matcher tpl_vars kont' subst'
+ where
+ kont' subst'' = kont (unBindSubstList subst'' vs1 vs2)
+ subst' = bindSubstList subst vs1 vs2
+
+ -- The unBindSubst relies on no shadowing in the template
+ not_in_subst v = not (maybeToBool (lookupSubst subst v))
+
+----------------------------------------
+match_ty ty1 ty2 tpl_vars kont subst
+ = case Unify.match ty1 ty2 tpl_vars Just (substEnv subst) of
+ Nothing -> match_fail
+ Just senv' -> kont (setSubstEnv subst senv')
+
+----------------------------------------
+matches [] [] tpl_vars kont subst
+ = kont subst
+matches (e:es) (e':es') tpl_vars kont subst
+ = match e e' tpl_vars (matches es es' tpl_vars kont) subst
+matches es es' tpl_vars kont subst
+ = match_fail
+
+----------------------------------------
+mkVarArg :: CoreBndr -> CoreArg
+mkVarArg v | isId v = Var v
+ | otherwise = Type (mkTyVarTy v)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Adding a new rule}
+%* *
+%************************************************************************
+
+\begin{code}
+addRule :: Id -> CoreRules -> CoreRule -> CoreRules
+
+-- Insert the new rule just before a rule that is *less specific*
+-- than the new one; or at the end if there isn't such a one.
+-- In this way we make sure that when looking up, the first match
+-- is the most specific.
+--
+-- We make no check for rules that unify without one dominating
+-- the other. Arguably this would be a bug.
+
+addRule id (Rules rules rhs_fvs) (Rule str tpl_vars tpl_args rhs)
+ = Rules (insert rules) (rhs_fvs `unionVarSet` new_rhs_fvs)
+ where
+ new_rule = Rule str tpl_vars' tpl_args rhs'
+ -- Add occ info to tpl_vars, rhs
+
+ (rhs_uds, rhs') = occurAnalyseExpr isLocallyDefined rhs
+ (rhs_uds1, tpl_vars') = tagBinders rhs_uds tpl_vars
+
+ insert [] = [new_rule]
+ insert (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
+ | otherwise = rule : insert rules
+
+ new_is_more_specific rule = maybeToBool (matchRule tpl_var_set rule tpl_args)
+
+ tpl_var_set = mkVarSet tpl_vars'
+ -- Actually we should probably include the free vars of tpl_args,
+ -- but I can't be bothered
+
+ new_rhs_fvs = (exprFreeVars rhs' `minusVarSet` tpl_var_set) `delVarSet` id
+ -- Hack alert!
+ -- Don't include the Id in its own rhs free-var set.
+ -- Otherwise the occurrence analyser makes bindings recursive
+ -- that shoudn't be. E.g.
+ -- RULE: f (f x y) z ==> f x (f y z)
+
+addIdSpecialisations :: Id -> [([CoreBndr], [CoreExpr], CoreExpr)] -> Id
+addIdSpecialisations id spec_stuff
+ = setIdSpecialisation id new_rules
+ where
+ rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id))
+ new_rules = foldr add (getIdSpecialisation id) spec_stuff
+ add (vars, args, rhs) rules = addRule id rules (Rule rule_name vars args rhs)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Preparing the rule base
+%* *
+%************************************************************************
+
+\begin{code}
+data ProtoCoreRule
+ = ProtoCoreRule
+ Bool -- True <=> this rule was defined in this module,
+ Id -- What Id is it for
+ CoreRule -- The rule itself
+
+
+pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (Just fn) rule
+
+lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+lookupRule in_scope fn args
+ = case getIdSpecialisation fn of
+ Rules rules _ -> matchRules in_scope rules args
+
+orphanRule :: ProtoCoreRule -> Bool
+-- An "orphan rule" is one that is defined in this
+-- module, but of ran *imported* function. We need
+-- to track these separately when generating the interface file
+orphanRule (ProtoCoreRule local fn _)
+ = local && not (isLocallyDefined fn)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Getting the rules ready}
+%* *
+%************************************************************************
+
+\begin{code}
+type RuleBase = (IdSet, -- Imported Ids that have rules attached
+ IdSet) -- Ids (whether local or imported) mentioned on
+ -- LHS of some rule; these should be black listed
+
+-- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
+-- so that the opportunity to apply the rule isn't lost too soon
+
+prepareRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase)
+prepareRuleBase binds rules
+ = (map zap_bind binds, (imported_rule_ids, rule_lhs_fvs))
+ where
+ (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) rules
+ imported_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
+
+ -- rule_fvs is the set of all variables mentioned in rules
+ rule_fvs = foldVarSet (unionVarSet . idRuleVars) rule_lhs_fvs rule_ids
+
+ -- Attach the rules for each locally-defined Id to that Id.
+ -- - This makes the rules easier to look up
+ -- - It means that transformation rules and specialisations for
+ -- locally defined Ids are handled uniformly
+ -- - It keeps alive things that are referred to only from a rule
+ -- (the occurrence analyser knows about rules attached to Ids)
+ -- - It makes sure that, when we apply a rule, the free vars
+ -- of the RHS are more likely to be in scope
+ --
+ -- The LHS and RHS Ids are marked 'no-discard'.
+ -- This means that the binding won't be discarded EVEN if the binding
+ -- ends up being trivial (v = w) -- the simplifier would usually just
+ -- substitute w for v throughout, but we don't apply the substitution to
+ -- the rules (maybe we should?), so this substitution would make the rule
+ -- bogus.
+ zap_bind (NonRec b r) = NonRec (zap_bndr b) r
+ zap_bind (Rec prs) = Rec [(zap_bndr b, r) | (b,r) <- prs]
+
+ zap_bndr bndr = case lookupVarSet rule_ids bndr of
+ Just bndr' -> setIdNoDiscard bndr'
+ Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr
+ | otherwise -> bndr
+
+add_rule (ProtoCoreRule _ id rule)
+ (rule_id_set, rule_fvs)
+ = (rule_id_set `extendVarSet` new_id,
+ rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
+ where
+ new_id = case lookupVarSet rule_id_set id of
+ Just id' -> addRuleToId id' rule
+ Nothing -> addRuleToId id rule
+ lhs_fvs = ruleSomeLhsFreeVars isId rule
+ -- Find *all* the free Ids of the LHS, not just
+ -- locally defined ones!!
+
+addRuleToId id rule = setIdSpecialisation id (addRule id (getIdSpecialisation id) rule)
+\end{code}
+
+++ /dev/null
-_interface_ SpecEnv 1
-_exports_
-SpecEnv SpecEnv ;
-_declarations_
-1 data SpecEnv a ;
-
__interface SpecEnv 1 0 where
-__export SpecEnv SpecEnv ;
+__export SpecEnv SpecEnv emptySpecEnv specEnvFreeVars isEmptySpecEnv ;
1 data SpecEnv a;
+1 emptySpecEnv :: __forall [a] => SpecEnv a ;
+1 isEmptySpecEnv :: __forall [a] => SpecEnv a -> PrelBase.Bool ;
+1 specEnvFreeVars :: __forall [a] => (a -> VarSet.IdOrTyVarSet) -> SpecEnv a -> VarSet.IdOrTyVarSet ;
+
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
-\section[SpecEnv]{Specialisation info about an @Id@}
-
-\begin{code}
-module SpecEnv (
- SpecEnv,
- emptySpecEnv, isEmptySpecEnv,
- specEnvValues, specEnvToList, specEnvFromList,
- addToSpecEnv, lookupSpecEnv, substSpecEnv
- ) where
-
-#include "HsVersions.h"
-
-import Var ( TyVar )
-import VarEnv
-import VarSet
-import Type ( Type, fullSubstTy, substTyVar )
-import Unify ( unifyTyListsX, matchTys )
-import Outputable
-import Maybes
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\section{SpecEnv}
-%* *
-%************************************************************************
-
-\begin{code}
-data SpecEnv value
- = EmptySE
- | SpecEnv [([TyVar], -- Really a set, but invariably small,
- -- so kept as a list
- [Type],
- value)]
-
-specEnvValues :: SpecEnv value -> [value]
-specEnvValues EmptySE = []
-specEnvValues (SpecEnv alist) = [val | (_,_,val) <- alist]
-
-specEnvToList :: SpecEnv value -> [([TyVar], [Type], value)]
-specEnvToList EmptySE = []
-specEnvToList (SpecEnv alist) = alist
-
-specEnvFromList :: [([TyVar], [Type], value)] -> SpecEnv value
- -- Assumes the list is in appropriate order
-specEnvFromList [] = EmptySE
-specEnvFromList alist = SpecEnv alist
-\end{code}
-
-In some SpecEnvs overlap is prohibited; that is, no pair of templates unify.
-
-In others, overlap is permitted, but only in such a way that one can make
-a unique choice when looking up. That is, overlap is only permitted if
-one template matches the other, or vice versa. So this is ok:
-
- [a] [Int]
-
-but this is not
-
- (Int,a) (b,Int)
-
-If overlap is permitted, the list is kept most specific first, so that
-the first lookup is the right choice.
-
-
-For now we just use association lists.
-
-\begin{code}
-emptySpecEnv :: SpecEnv a
-emptySpecEnv = EmptySE
-
-isEmptySpecEnv EmptySE = True
-isEmptySpecEnv _ = False
-\end{code}
-
-@lookupSpecEnv@ looks up in a @SpecEnv@, using a one-way match. Since the env is kept
-ordered, the first match must be the only one.
-The thing we are looking up can have an
-arbitrary "flexi" part.
-
-\begin{code}
-lookupSpecEnv :: SDoc -- For error report
- -> SpecEnv value -- The envt
- -> [Type] -- Key
- -> Maybe (TyVarEnv Type, value)
-
-lookupSpecEnv doc EmptySE key = Nothing
-lookupSpecEnv doc (SpecEnv alist) key
- = find alist
- where
- find [] = Nothing
- find ((tpl_tyvars, tpl, val) : rest)
- = case matchTys tpl_tyvars tpl key of
- Nothing -> find rest
- Just (subst, leftovers) -> ASSERT( null leftovers )
- Just (subst, val)
-\end{code}
-
-@addToSpecEnv@ extends a @SpecEnv@, checking for overlaps.
-
-A boolean flag controls overlap reporting.
-
-True => overlap is permitted, but only if one template matches the other;
- not if they unify but neither is
-
-\begin{code}
-addToSpecEnv :: Bool -- True <=> overlap permitted
- -> SpecEnv value -- Envt
- -> [TyVar] -> [Type] -> value -- New item
- -> MaybeErr (SpecEnv value) -- Success...
- ([Type], value) -- Failure: Offending overlap
-
-addToSpecEnv overlap_ok spec_env ins_tvs ins_tys value
- = case spec_env of
- EmptySE -> returnMaB (SpecEnv [ins_item])
- SpecEnv alist -> insert alist `thenMaB` \ alist' ->
- returnMaB (SpecEnv alist')
- where
- ins_item = (ins_tvs, ins_tys, value)
-
- insert [] = returnMaB [ins_item]
- insert alist@(cur_item@(tpl_tvs, tpl_tys, val) : rest)
-
- -- FAIL if:
- -- (a) they are the same, or
- -- (b) they unify, and any sort of overlap is prohibited,
- -- (c) they unify but neither is more specific than t'other
- | identical
- || (unifiable && not overlap_ok)
- || (unifiable && not (ins_item_more_specific || cur_item_more_specific))
- = failMaB (tpl_tys, val)
-
- -- New item is an instance of current item, so drop it here
- | ins_item_more_specific = returnMaB (ins_item : alist)
-
- -- Otherwise carry on
- | otherwise = insert rest `thenMaB` \ rest' ->
- returnMaB (cur_item : rest')
- where
- unifiable = maybeToBool (unifyTyListsX (ins_tvs ++ tpl_tvs) tpl_tys ins_tys)
- ins_item_more_specific = maybeToBool (matchTys tpl_tvs tpl_tys ins_tys)
- cur_item_more_specific = maybeToBool (matchTys ins_tvs ins_tys tpl_tys)
- identical = ins_item_more_specific && cur_item_more_specific
-\end{code}
-
-Finally, during simplification we must apply the current substitution to
-the SpecEnv.
-
-\begin{code}
-substSpecEnv :: TyVarEnv Type -> IdOrTyVarSet
- -> (TyVarEnv Type -> IdOrTyVarSet -> val -> val)
- -> SpecEnv val -> SpecEnv val
-substSpecEnv ty_subst in_scope val_fn EmptySE = EmptySE
-substSpecEnv ty_subst in_scope val_fn (SpecEnv alist)
- = SpecEnv (map subst alist)
- where
- subst (tpl_tyvars, tpl_tys, val)
- = (tpl_tyvars',
- map (fullSubstTy ty_subst' in_scope') tpl_tys,
- val_fn ty_subst' in_scope' val)
- where
- (ty_subst', in_scope', tpl_tyvars') = go ty_subst in_scope [] tpl_tyvars
-
- go s i acc [] = (s, i, reverse acc)
- go s i acc (tv:tvs) = case substTyVar s i tv of
- (s', i', tv') -> go s' i' (tv' : acc) tvs
-\end{code}
#include "HsVersions.h"
-import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_spec )
+import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_spec, opt_D_dump_rules )
import Id ( Id, idName, idType, mkTemplateLocals, mkUserLocal,
- getIdSpecialisation, setIdSpecialisation,
- isSpecPragmaId,
+ getIdSpecialisation, setIdNoDiscard, isExportedId,
+ modifyIdInfo
)
+import IdInfo ( zapSpecPragInfo )
import VarSet
import VarEnv
-import Type ( Type, TyVarSubst, mkTyVarTy, splitSigmaTy, substTy,
- fullSubstTy, tyVarsOfType, tyVarsOfTypes,
+import Type ( Type, mkTyVarTy, splitSigmaTy, splitFunTysN,
+ tyVarsOfType, tyVarsOfTypes, applyTys,
mkForAllTys, boxedTypeKind
)
+import Subst ( Subst, mkSubst, substTy, emptySubst, substBndrs, extendSubstList,
+ substExpr, substId, substIds, substAndCloneId, substAndCloneIds, lookupSubst
+ )
import Var ( TyVar, mkSysTyVar, setVarUnique )
import VarSet
import VarEnv
import CoreSyn
-import CoreUtils ( IdSubst, SubstCoreExpr(..), exprFreeVars,
- substExpr, substId, substIds, coreExprType
- )
+import CoreUtils ( coreExprType, applyTypeToArgs )
+import CoreFVs ( exprFreeVars, exprsFreeVars )
import CoreLint ( beginPass, endPass )
-import PprCore () -- Instances
-import SpecEnv ( addToSpecEnv )
+import PprCore ( pprCoreRules )
+import Rules ( addIdSpecialisations )
import UniqSupply ( UniqSupply,
UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs,
import Name ( nameOccName, mkSpecOcc, getSrcLoc )
import FiniteMap
import Maybes ( MaybeErr(..), catMaybes )
+import ErrUtils ( dumpIfSet )
import Bag
import List ( partition )
-import Util ( zipEqual, mapAccumL )
+import Util ( zipEqual, zipWithEqual, mapAccumL )
import Outputable
endPass "Specialise" (opt_D_dump_spec || opt_D_verbose_core2core) binds'
+ dumpIfSet opt_D_dump_rules "Top-level specialisations"
+ (vcat (map dump_specs (concat (map bindersOf binds'))))
+
+ return binds'
where
go [] = returnSM ([], emptyUDs)
- go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
- specBind bind uds `thenSM` \ (bind', uds') ->
+ go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
+ specBind emptySubst bind uds `thenSM` \ (bind', uds') ->
returnSM (bind' ++ binds', uds')
+
+dump_specs var = pprCoreRules var (getIdSpecialisation var)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-specExpr :: CoreExpr -> SpecM (CoreExpr, UsageDetails)
+specVar :: Subst -> Id -> CoreExpr
+specVar subst v = case lookupSubst subst v of
+ Nothing -> Var v
+ Just (DoneEx e) -> e
+
+specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
+-- We carry a substitution down:
+-- a) we must clone any binding that might flaot outwards,
+-- to avoid name clashes
+-- b) we carry a type substitution to use when analysing
+-- the RHS of specialised bindings (no type-let!)
---------------- First the easy cases --------------------
-specExpr e@(Type _) = returnSM (e, emptyUDs)
-specExpr e@(Var _) = returnSM (e, emptyUDs)
+specExpr subst (Type ty) = returnSM (Type (substTy subst ty), emptyUDs)
+specExpr subst (Var v) = returnSM (specVar subst v, emptyUDs)
-specExpr e@(Con con args)
- = mapAndCombineSM specExpr args `thenSM` \ (args', uds) ->
+specExpr subst e@(Con con args)
+ = mapAndCombineSM (specExpr subst) args `thenSM` \ (args', uds) ->
returnSM (Con con args', uds)
-specExpr (Note note body)
- = specExpr body `thenSM` \ (body', uds) ->
- returnSM (Note note body', uds)
+specExpr subst (Note note body)
+ = specExpr subst body `thenSM` \ (body', uds) ->
+ returnSM (Note (specNote subst note) body', uds)
---------------- Applications might generate a call instance --------------------
-specExpr expr@(App fun arg)
+specExpr subst expr@(App fun arg)
= go expr []
where
- go (App fun arg) args = specExpr arg `thenSM` \ (arg', uds_arg) ->
+ go (App fun arg) args = specExpr subst arg `thenSM` \ (arg', uds_arg) ->
go fun (arg':args) `thenSM` \ (fun', uds_app) ->
returnSM (App fun' arg', uds_arg `plusUDs` uds_app)
- go (Var f) args = returnSM (Var f, mkCallUDs f args)
- go other args = specExpr other
+ go (Var f) args = case specVar subst f of
+ Var f' -> returnSM (Var f', mkCallUDs f' args)
+ e' -> returnSM (e', emptyUDs) -- I don't expect this!
+ go other args = specExpr subst other
---------------- Lambda/case require dumping of usage details --------------------
-specExpr e@(Lam _ _)
- = specExpr body `thenSM` \ (body', uds) ->
+specExpr subst e@(Lam _ _)
+ = specExpr subst' body `thenSM` \ (body', uds) ->
let
- (filtered_uds, body'') = dumpUDs bndrs uds body'
+ (filtered_uds, body'') = dumpUDs bndrs' uds body'
in
- returnSM (mkLams bndrs body'', filtered_uds)
+ returnSM (mkLams bndrs' body'', filtered_uds)
where
- (bndrs, body) = go [] e
-
+ (bndrs, body) = collectBinders e
+ (subst', bndrs') = substBndrs subst bndrs
-- More efficient to collect a group of binders together all at once
-- and we don't want to split a lambda group with dumped bindings
- go bndrs (Lam bndr e) = go (bndr:bndrs) e
- go bndrs e = (reverse bndrs, e)
-
-specExpr (Case scrut case_bndr alts)
- = specExpr scrut `thenSM` \ (scrut', uds_scrut) ->
+specExpr subst (Case scrut case_bndr alts)
+ = specExpr subst scrut `thenSM` \ (scrut', uds_scrut) ->
mapAndCombineSM spec_alt alts `thenSM` \ (alts', uds_alts) ->
- returnSM (Case scrut' case_bndr alts', uds_scrut `plusUDs` uds_alts)
+ returnSM (Case scrut' case_bndr' alts', uds_scrut `plusUDs` uds_alts)
where
+ (subst_alt, case_bndr') = substId subst case_bndr
+
spec_alt (con, args, rhs)
- = specExpr rhs `thenSM` \ (rhs', uds) ->
+ = specExpr subst_rhs rhs `thenSM` \ (rhs', uds) ->
let
(uds', rhs'') = dumpUDs args uds rhs'
in
- returnSM ((con, args, rhs''), uds')
+ returnSM ((con, args', rhs''), uds')
+ where
+ (subst_rhs, args') = substBndrs subst_alt args
---------------- Finally, let is the interesting case --------------------
-specExpr (Let bind body)
- = -- Deal with the body
- specExpr body `thenSM` \ (body', body_uds) ->
+specExpr subst (Let bind body)
+ = -- Clone binders
+ cloneBindSM subst bind `thenSM` \ (rhs_subst, body_subst, bind') ->
+
+ -- Deal with the body
+ specExpr body_subst body `thenSM` \ (body', body_uds) ->
-- Deal with the bindings
- specBind bind body_uds `thenSM` \ (binds', uds) ->
+ specBind rhs_subst bind' body_uds `thenSM` \ (binds', uds) ->
-- All done
returnSM (foldr Let body' binds', uds)
+
+-- Must apply the type substitution to coerceions
+specNote subst (Coerce t1 t2) = Coerce (substTy subst t1) (substTy subst t2)
+specNote subst note = note
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-specBind :: CoreBind
+specBind :: Subst -- Use this for RHSs
+ -> CoreBind
-> UsageDetails -- Info on how the scope of the binding
-> SpecM ([CoreBind], -- New bindings
UsageDetails) -- And info to pass upstream
-specBind bind@(NonRec bndr rhs) body_uds
- | isSpecPragmaId bndr -- Aha! A spec-pragma Id. Collect UDs from
- -- its RHS and discard it!
- = specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
- returnSM ([], rhs_uds `plusUDs` body_uds)
-
-
-specBind bind body_uds
- = specBindItself bind (calls body_uds) `thenSM` \ (bind', bind_uds) ->
+specBind rhs_subst bind body_uds
+ = specBindItself rhs_subst bind (calls body_uds) `thenSM` \ (bind', bind_uds) ->
let
bndrs = bindersOf bind
all_uds = zapCalls bndrs (body_uds `plusUDs` bind_uds)
-- specBindItself deals with the RHS, specialising it according
-- to the calls found in the body (if any)
-specBindItself (NonRec bndr rhs) call_info
- = specDefn call_info (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
+specBindItself rhs_subst (NonRec bndr rhs) call_info
+ = specDefn rhs_subst call_info (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
let
new_bind | null spec_defns = NonRec bndr' rhs'
| otherwise = Rec ((bndr',rhs'):spec_defns)
in
returnSM (new_bind, spec_uds)
-specBindItself (Rec pairs) call_info
- = mapSM (specDefn call_info) pairs `thenSM` \ stuff ->
+specBindItself rhs_subst (Rec pairs) call_info
+ = mapSM (specDefn rhs_subst call_info) pairs `thenSM` \ stuff ->
let
(pairs', spec_defns_s, spec_uds_s) = unzip3 stuff
spec_defns = concat spec_defns_s
returnSM (new_bind, spec_uds)
-specDefn :: CallDetails -- Info on how it is used in its scope
+specDefn :: Subst -- Subst to use for RHS
+ -> CallDetails -- Info on how it is used in its scope
-> (Id, CoreExpr) -- The thing being bound and its un-processed RHS
-> SpecM ((Id, CoreExpr), -- The thing and its processed RHS
-- the Id may now have specialisations attached
UsageDetails -- Stuff to fling upwards from the RHS and its
) -- specialised versions
-specDefn calls (fn, rhs)
+specDefn subst calls (fn, rhs)
-- The first case is the interesting one
| n_tyvars == length rhs_tyvars -- Rhs of fn's defn has right number of big lambdas
&& n_dicts <= length rhs_bndrs -- and enough dict args
&& not (null calls_for_me) -- And there are some calls to specialise
= -- Specialise the body of the function
- specExpr body `thenSM` \ (body', body_uds) ->
- let
- (float_uds, bound_uds@(dict_binds,_)) = splitUDs rhs_bndrs body_uds
- in
+ specExpr subst rhs `thenSM` \ (rhs', rhs_uds) ->
-- Make a specialised version for each call in calls_for_me
- mapSM (spec_call bound_uds) calls_for_me `thenSM` \ stuff ->
+ mapSM spec_call calls_for_me `thenSM` \ stuff ->
let
(spec_defns, spec_uds, spec_env_stuff) = unzip3 stuff
- fn' = addIdSpecialisations fn spec_env_stuff
- rhs' = mkLams rhs_bndrs (mkDictLets dict_binds body')
+ fn' = addIdSpecialisations zapped_fn spec_env_stuff
in
returnSM ((fn',rhs'),
spec_defns,
- float_uds `plusUDs` plusUDList spec_uds)
+ rhs_uds `plusUDs` plusUDList spec_uds)
| otherwise -- No calls or RHS doesn't fit our preconceptions
- = specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
- returnSM ((fn, rhs'), [], rhs_uds)
+ = specExpr subst rhs `thenSM` \ (rhs', rhs_uds) ->
+ returnSM ((zapped_fn, rhs'), [], rhs_uds)
where
+ zapped_fn = modifyIdInfo zapSpecPragInfo fn
+ -- If the fn is a SpecPragmaId, make it discardable
+ -- It's role as a holder for a call instance is o'er
+ -- But it might be alive for some other reason by now.
+
fn_type = idType fn
(tyvars, theta, tau) = splitSigmaTy fn_type
n_tyvars = length tyvars
----------------------------------------------------------
-- Specialise to one particular call pattern
- spec_call :: ProtoUsageDetails -- From the original body, captured by
- -- the dictionary lambdas
- -> ([Maybe Type], ([DictExpr], IdOrTyVarSet)) -- Call instance
- -> SpecM ((Id,CoreExpr), -- Specialised definition
- UsageDetails, -- Usage details from specialised body
- ([TyVar], [Type], CoreExpr)) -- Info for the Id's SpecEnv
- spec_call bound_uds (call_ts, (call_ds, _))
+ spec_call :: ([Maybe Type], ([DictExpr], IdOrTyVarSet)) -- Call instance
+ -> SpecM ((Id,CoreExpr), -- Specialised definition
+ UsageDetails, -- Usage details from specialised body
+ ([CoreBndr], [CoreExpr], CoreExpr)) -- Info for the Id's SpecEnv
+ spec_call (call_ts, (call_ds, call_fvs))
= ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts )
-- Calls are only recorded for properly-saturated applications
- -- Supppose the call is for f [Just t1, Nothing, Just t3, Nothing] [d1, d2]
-
- -- Construct the new binding
- -- f1 = /\ b d -> (..rhs of f..) t1 b t3 d d1 d2
- -- and the type of this binder
- let
- mk_spec_ty Nothing = newTyVarSM `thenSM` \ tyvar ->
- returnSM (Just tyvar, mkTyVarTy tyvar)
- mk_spec_ty (Just ty) = returnSM (Nothing, ty)
- in
- mapSM mk_spec_ty call_ts `thenSM` \ stuff ->
+ -- Suppose f's defn is f = /\ a b c d -> \ d1 d2 -> rhs
+ -- Supppose the call is for f [Just t1, Nothing, Just t3, Nothing] [dx1, dx2]
+
+ -- Construct the new binding
+ -- f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b d -> rhs)
+ -- PLUS the usage-details
+ -- { d1' = dx1; d2' = dx2 }
+ -- where d1', d2' are cloned versions of d1,d2, with the type substitution applied.
+ --
+ -- Note that the substitution is applied to the whole thing.
+ -- This is convenient, but just slightly fragile. Notably:
+ -- * There had better be no name clashes in a/b/c/d
+ --
let
- (maybe_spec_tyvars, spec_tys) = unzip stuff
- spec_tyvars = catMaybes maybe_spec_tyvars
- spec_id_ty = mkForAllTys spec_tyvars
- (substTy (zipVarEnv tyvars spec_tys) tau)
- -- NB When substituting in tau we need a ty_env mentioning tyvars
- -- but when substituting in UDs we need a ty_evn mentioning rhs_tyvars
- ud_ty_env = zipVarEnv rhs_tyvars spec_tys
- ud_dict_env = zipVarEnv rhs_dicts (map Done call_ds)
-
- -- Only the overloaded tyvars should be free in the uds
- ty_env = mkVarEnv [ (rhs_tyvar, ty)
- | (rhs_tyvar, Just ty) <- zipEqual "specUDs1" rhs_tyvars call_ts
- ]
-
+ -- poly_tyvars = [b,d] in the example above
+ -- spec_tyvars = [a,c]
+ -- ty_args = [t1,b,t3,d]
+ poly_tyvars = [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
+ spec_tyvars = [tv | (tv, Just _) <- rhs_tyvars `zip` call_ts]
+ ty_args = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts
+ where
+ mk_ty_arg rhs_tyvar Nothing = Type (mkTyVarTy rhs_tyvar)
+ mk_ty_arg rhs_tyvar (Just ty) = Type ty
+ rhs_subst = extendSubstList subst spec_tyvars [DoneTy ty | Just ty <- call_ts]
in
-
- -- Specialise the UDs from f's RHS
- specUDs ud_ty_env ud_dict_env bound_uds `thenSM` \ spec_uds ->
-
-
- -- Construct the stuff for f's spec env
- -- [b,d] [t1,b,t3,d] |-> \d1 d2 -> f1 b d
- -- The only awkward bit is that d1,d2 might well be global
- -- dictionaries, so it's tidier to make new local variables
- -- for the lambdas in the RHS, rather than lambda-bind the
- -- dictionaries themselves.
- --
- -- In fact we use the standard template locals, so that the
- -- they don't need to be "tidied" before putting in interface files
- newIdSM fn spec_id_ty `thenSM` \ spec_f ->
+ cloneBinders rhs_subst rhs_dicts `thenSM` \ (rhs_subst', rhs_dicts') ->
let
- arg_ds = mkTemplateLocals (map coreExprType call_ds)
- spec_env_rhs = mkLams arg_ds $
- mkTyApps (Var spec_f) $
- map mkTyVarTy spec_tyvars
- spec_env_info = (spec_tyvars, spec_tys, spec_env_rhs)
- in
-
- -- Finally construct f's RHS
- -- Annoyingly, the specialised UDs may mention some of the *un* specialised
- -- type variables. Here's a case that came up in nofib/spectral/typech98:
- -- f = /\m a -> \d:Monad m -> let d':Monad (T m a) = ...a... in ...
- -- When we try to make a specialised verison of f, from a call pattern
- -- (f Maybe ?)
- -- where ? is the Nothing for an unspecialised position, we must get
- -- spec_f = /\ a -> let d':Monad (T Maybe a) = ...a... in ....
- -- If we don't do the splitUDs below, the d' binding floats out too far.
- -- Sigh. What a mess.
- let
- (float_uds, (dict_binds,_)) = splitUDs spec_tyvars spec_uds
+ inst_args = ty_args ++ map Var rhs_dicts'
- spec_rhs = mkLams spec_tyvars $
- mkDictLets dict_binds $
- mkApps rhs (map Type spec_tys ++ call_ds)
+ -- Figure out the type of the specialised function
+ spec_id_ty = mkForAllTys poly_tyvars (applyTypeToArgs rhs fn_type inst_args)
+ in
+ newIdSM fn spec_id_ty `thenSM` \ spec_f ->
+ specExpr rhs_subst' (mkLams poly_tyvars body) `thenSM` \ (spec_rhs, rhs_uds) ->
+ let
+ -- The rule to put in the function's specialisation is:
+ -- forall b,d, d1',d2'. f t1 b t3 d d1' d2' = f1 b d
+ spec_env_rule = (poly_tyvars ++ rhs_dicts',
+ inst_args,
+ mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
+
+ -- Add the { d1' = dx1; d2' = dx2 } usage stuff
+ final_uds = foldr addDictBind rhs_uds (zipEqual "spec_call" rhs_dicts' call_ds)
in
returnSM ((spec_f, spec_rhs),
- float_uds,
- spec_env_info
- )
+ final_uds,
+ spec_env_rule)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-type FreeDicts = IdSet
-
data UsageDetails
= MkUD {
dict_binds :: !(Bag DictBind),
-- The order is important;
-- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
-- (Remember, Bags preserve order in GHC.)
- -- The FreeDicts is the free vars of the RHS
calls :: !CallDetails
}
------------------------------------------------------------
type CallDetails = FiniteMap Id CallInfo
-type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument
- ([DictExpr], IdSet) -- Dict args and the free dicts
- -- free dicts does *not* include the main id itself
+type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument
+ ([DictExpr], IdOrTyVarSet) -- Dict args and the vars of the whole
+ -- call (including tyvars)
+ -- [*not* include the main id itself, of course]
-- The finite maps eliminate duplicates
-- The list of types and dictionaries is guaranteed to
-- match the type of f
unionCalls :: CallDetails -> CallDetails -> CallDetails
unionCalls c1 c2 = plusFM_C plusFM c1 c2
+singleCall :: (Id, [Maybe Type], [DictExpr]) -> CallDetails
singleCall (id, tys, dicts)
- = unitFM id (unitFM tys (dicts, dict_fvs))
+ = unitFM id (unitFM tys (dicts, call_fvs))
where
- dict_fvs = foldr (unionVarSet . exprFreeVars) emptyVarSet dicts
+ call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
+ tys_fvs = tyVarsOfTypes (catMaybes tys)
-- The type args (tys) are guaranteed to be part of the dictionary
-- types, because they are just the constrained types,
-- and the dictionary is therefore sure to be bound
-- inside the binding for any type variables free in the type;
-- hence it's safe to neglect tyvars free in tys when making
-- the free-var set for this call
+ -- BUT I don't trust this reasoning; play safe and include tys_fvs
--
-- We don't include the 'id' itself.
mkDB bind = (bind, bind_fvs bind)
bind_fvs (NonRec bndr rhs) = exprFreeVars rhs
-bind_fvs (Rec prs) = foldl delVarSet rhs_fvs (map fst prs)
+bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs
where
- rhs_fvs = foldr (unionVarSet . exprFreeVars . snd) emptyVarSet prs
+ bndrs = map fst prs
+ rhs_fvs = unionVarSets [exprFreeVars rhs | (bndr,rhs) <- prs]
-addDictBind uds bind = uds { dict_binds = mkDB bind `consBag` dict_binds uds }
+addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds }
dumpAllDictBinds (MkUD {dict_binds = dbs}) binds
= foldrBag add binds dbs
where
add (bind,_) binds = bind : binds
-mkDictBinds :: [DictBind] -> [CoreBind]
-mkDictBinds = map fst
-
-mkDictLets :: [DictBind] -> CoreExpr -> CoreExpr
-mkDictLets dbs body = foldr mk body dbs
- where
- mk (bind,_) e = Let bind e
-
dumpUDs :: [CoreBndr]
-> UsageDetails -> CoreExpr
-> (UsageDetails, CoreExpr)
dumpUDs bndrs uds body
- = (free_uds, mkDictLets dict_binds body)
+ = (free_uds, foldr add_let body dict_binds)
where
(free_uds, (dict_binds, _)) = splitUDs bndrs uds
+ add_let (bind,_) body = Let bind body
splitUDs :: [CoreBndr]
-> UsageDetails
= (free_dbs `snocBag` db, dump_dbs, dump_idset)
\end{code}
-Given a type and value substitution, specUDs creates a specialised copy of
-the given UDs
-
-\begin{code}
-specUDs :: TyVarSubst -> IdSubst -> ProtoUsageDetails -> SpecM UsageDetails
-specUDs tv_env dict_env (dbs, calls)
- = getUniqSupplySM `thenSM` \ us ->
- let
- ((us', dict_env'), dbs') = mapAccumL specDB (us, dict_env) dbs
- in
- setUniqSupplySM us' `thenSM_`
- returnSM (MkUD { dict_binds = listToBag dbs',
- calls = foldr (unionCalls . singleCall . inst_call dict_env')
- emptyFM calls
- })
- where
- inst_call dict_env (id, tys, (dicts,fvs)) = (id, map (inst_maybe_ty fvs) tys,
- map (substExpr tv_env dict_env fvs) dicts)
-
- inst_maybe_ty fvs Nothing = Nothing
- inst_maybe_ty fvs (Just ty) = Just (fullSubstTy tv_env fvs ty)
-
- specDB (us, dict_env) (NonRec bndr rhs, fvs)
- = ((us', dict_env'), mkDB (NonRec bndr' (substExpr tv_env dict_env fvs rhs)))
- where
- (dict_env', _, us', bndr') = substId clone_fn tv_env dict_env fvs us bndr
- -- Fudge the in_scope set a bit by using the free vars of
- -- the binding, and ignoring the one that comes back
-
- specDB (us, dict_env) (Rec prs, fvs)
- = ((us', dict_env'), mkDB (Rec (bndrs' `zip` rhss')))
- where
- (dict_env', _, us', bndrs') = substIds clone_fn tv_env dict_env fvs us (map fst prs)
- rhss' = [substExpr tv_env dict_env' fvs rhs | (_, rhs) <- prs]
-
- clone_fn _ us id = case splitUniqSupply us of
- (us1, us2) -> Just (us1, setVarUnique id (uniqFromSupply us2))
-\end{code}
%************************************************************************
%* *
Nothing -> id
Just id' -> id'
-addIdSpecialisations id spec_stuff
- = (if not (null errs) then
- pprTrace "Duplicate specialisations" (vcat (map ppr errs))
- else \x -> x
- )
- setIdSpecialisation id new_spec_env
- where
- (new_spec_env, errs) = foldr add (getIdSpecialisation id, []) spec_stuff
-
- add (tyvars, tys, template) (spec_env, errs)
- = case addToSpecEnv True spec_env tyvars tys template of
- Succeeded spec_env' -> (spec_env', errs)
- Failed err -> (spec_env, err:errs)
-
----------------------------------------
type SpecM a = UniqSM a
mapAndCombineSM f xs `thenSM` \ (ys, uds2) ->
returnSM (y:ys, uds1 `plusUDs` uds2)
+cloneBindSM :: Subst -> CoreBind -> SpecM (Subst, Subst, CoreBind)
+-- Clone the binders of the bind; return new bind with the cloned binders
+-- Return the substitution to use for RHSs, and the one to use for the body
+cloneBindSM subst (NonRec bndr rhs)
+ = getUs `thenUs` \ us ->
+ let
+ (subst', us', bndr') = substAndCloneId subst us bndr
+ in
+ setUs us' `thenUs_`
+ returnUs (subst, subst', NonRec bndr' rhs)
+
+cloneBindSM subst (Rec pairs)
+ = getUs `thenUs` \ us ->
+ let
+ (subst', us', bndrs') = substAndCloneIds subst us (map fst pairs)
+ in
+ setUs us' `thenUs_`
+ returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs))
+
+cloneBinders subst bndrs
+ = getUs `thenUs` \ us ->
+ let
+ (subst', us', bndrs') = substAndCloneIds subst us bndrs
+ in
+ setUs us' `thenUs_`
+ returnUs (subst', bndrs')
+
+
newIdSM old_id new_ty
= getUniqSM `thenSM` \ uniq ->
let
-- Give the new Id a similar occurrence name to the old one
- new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name)
name = idName old_id
+ new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name)
+
+ -- If the old Id was exported, make the new one non-discardable,
+ -- else we will discard it since it doesn't seem to be called.
+ new_id' | isExportedId old_id = setIdNoDiscard new_id
+ | otherwise = new_id
in
- returnSM new_id
+ returnSM new_id'
newTyVarSM
= getUniqSM `thenSM` \ uniq ->
import CoreUtils ( coreExprType )
import SimplUtils ( findDefault )
import CostCentre ( noCCS )
-import Id ( Id, mkSysLocal, idType,
+import Id ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId,
externallyVisibleId, setIdUnique, idName, getIdDemandInfo
)
import Var ( Var, varType, modifyIdInfo )
-import IdInfo ( setDemandInfo )
+import IdInfo ( setDemandInfo, StrictnessInfo(..) )
import UsageSPUtils ( primOpUsgTys )
import DataCon ( DataCon, dataConName, dataConId )
+import Demand ( Demand, isStrict, wwStrict, wwLazy )
import Name ( Name, nameModule, isLocallyDefinedName )
import Module ( isDynamicModule )
-import Const ( Con(..), Literal, isLitLitLit )
+import Const ( Con(..), Literal(..), isLitLitLit, conStrictness, isWHNFCon )
import VarEnv
-import Const ( Con(..), isWHNFCon, Literal(..) )
-import PrimOp ( PrimOp(..), primOpUsg )
+import PrimOp ( PrimOp(..), primOpUsg, primOpSig )
import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
- UsageAnn(..), tyUsg, applyTy )
+ UsageAnn(..), tyUsg, applyTy, mkUsgTy )
import TysPrim ( intPrimTy )
-import Demand
-import Unique ( Unique, Uniquable(..) )
import UniqSupply -- all of it, really
-import Util
+import Util ( lengthExceeds )
+import BasicTypes ( TopLevelFlag(..) )
import Maybes
import Outputable
\end{code}
+ *************************************************
*************** OVERVIEW *********************
+ *************************************************
-The business of this pass is to convert Core to Stg. On the way:
+The business of this pass is to convert Core to Stg. On the way it
+does some important transformations:
-* We discard type lambdas and applications. In so doing we discard
- "trivial" bindings such as
+1. We discard type lambdas and applications. In so doing we discard
+ "trivial" bindings such as
x = y t1 t2
- where t1, t2 are types
+ where t1, t2 are types
+
+2. We get the program into "A-normal form". In particular:
+
+ f E ==> let x = E in f x
+ OR ==> case E of x -> f x
+
+ where E is a non-trivial expression.
+ Which transformation is used depends on whether f is strict or not.
+ [Previously the transformation to case used to be done by the
+ simplifier, but it's better done here. It does mean that f needs
+ to have its strictness info correct!.]
+
+ Similarly, convert any unboxed let's into cases.
+ [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form
+ right up to this point.]
+
+3. We clone all local binders. The code generator uses the uniques to
+ name chunks of code for thunks, so it's important that the names used
+ are globally unique, not simply not-in-scope, which is all that
+ the simplifier ensures.
+
+
+NOTE THAT:
* We don't pin on correct arities any more, because they can be mucked up
by the lambda lifter. In particular, the lambda lifter can take a local
\begin{code}
type StgEnv = IdEnv Id
-data StgFloatBind = StgFloatBind Id StgExpr RhsDemand
+data StgFloatBind = NoBindF
+ | NonRecF Id StgExpr RhsDemand
+ | RecF [(Id, StgRhs)]
\end{code}
A @RhsDemand@ gives the demand on an RHS: strict (@isStrictDem@) and
isOnceDem :: Bool -- True => used at most once
}
-tyDem :: Type -> RhsDemand
--- derive RhsDemand (assuming let-binding)
-tyDem ty = case tyUsg ty of
- UsOnce -> RhsDemand False True
- UsMany -> RhsDemand False False
- UsVar _ -> pprPanic "CoreToStg.tyDem: UsVar unexpected:" $ ppr ty
+mkDem :: Demand -> Bool -> RhsDemand
+mkDem strict once = RhsDemand (isStrict strict) once
+
+mkDemTy :: Demand -> Type -> RhsDemand
+mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
-bdrDem :: Var -> RhsDemand
-bdrDem = tyDem . varType
+isOnceTy :: Type -> Bool
+isOnceTy ty = case tyUsg ty of
+ UsOnce -> True
+ UsMany -> False
+
+bdrDem :: Id -> RhsDemand
+bdrDem id = mkDem (getIdDemandInfo id) (isOnceTy (idType id))
safeDem, onceDem :: RhsDemand
safeDem = RhsDemand False False -- always safe to use this
coreBindsToStg env [] = returnUs []
coreBindsToStg env (b:bs)
- = coreBindToStg env b `thenUs` \ (new_b, new_env) ->
+ = coreBindToStg TopLevel env b `thenUs` \ (bind_spec, new_env) ->
coreBindsToStg new_env bs `thenUs` \ new_bs ->
- returnUs (new_b ++ new_bs)
+ let
+ res_bs = case bind_spec of
+ NonRecF bndr rhs dem -> ASSERT2( not (isStrictDem dem) && not (isUnLiftedType (idType bndr)),
+ ppr b )
+ -- No top-level cases!
+ StgNonRec bndr (exprToRhs dem rhs) : new_bs
+ RecF prs -> StgRec prs : new_bs
+ NoBindF -> pprTrace "topCoreBindsToStg" (ppr b) new_bs
+ in
+ returnUs res_bs
\end{code}
+
%************************************************************************
%* *
\subsection[coreToStg-binds]{Converting bindings}
%************************************************************************
\begin{code}
-coreBindToStg :: StgEnv
- -> CoreBind
- -> UniqSM ([StgBinding], -- Empty or singleton
- StgEnv) -- Floats
-
-coreBindToStg env (NonRec binder rhs)
- = coreRhsToStg env rhs (bdrDem binder) `thenUs` \ stg_rhs ->
- newLocalId env binder `thenUs` \ (new_env, new_binder) ->
- returnUs ([StgNonRec new_binder stg_rhs], new_env)
-
-coreBindToStg env (Rec pairs)
- = newLocalIds env binders `thenUs` \ (env', binders') ->
- mapUs (\ (bdr,rhs) -> coreRhsToStg env' rhs (bdrDem bdr) )
- pairs `thenUs` \ stg_rhss ->
- returnUs ([StgRec (binders' `zip` stg_rhss)], env')
+coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
+
+coreBindToStg top_lev env (NonRec binder rhs)
+ = coreExprToStg env rhs dem `thenUs` \ stg_rhs ->
+ case stg_rhs of
+ StgApp var [] | not (isExportedId binder)
+ -> returnUs (NoBindF, extendVarEnv env binder var)
+ -- A trivial binding let x = y in ...
+ -- can arise if postSimplExpr floats a NoRep literal out
+ -- so it seems sensible to deal with it well.
+ -- But we don't want to discard exported things. They can
+ -- occur; e.g. an exported user binding f = g
+
+ other -> newLocalId top_lev env binder `thenUs` \ (new_env, new_binder) ->
+ returnUs (NonRecF new_binder stg_rhs dem, new_env)
+ where
+ dem = bdrDem binder
+
+coreBindToStg top_lev env (Rec pairs)
+ = newLocalIds top_lev env binders `thenUs` \ (env', binders') ->
+ mapUs (do_rhs env') pairs `thenUs` \ stg_rhss ->
+ returnUs (RecF (binders' `zip` stg_rhss), env')
where
- (binders, rhss) = unzip pairs
+ binders = map fst pairs
+ do_rhs env (bndr,rhs) = coreRhsToStg env rhs (bdrDem bndr)
\end{code}
\begin{code}
coreRhsToStg :: StgEnv -> CoreExpr -> RhsDemand -> UniqSM StgRhs
-
-coreRhsToStg env core_rhs dem
- = coreExprToStg env core_rhs dem `thenUs` \ stg_expr ->
+coreRhsToStg env rhs dem
+ = coreExprToStg env rhs dem `thenUs` \ stg_expr ->
returnUs (exprToRhs dem stg_expr)
+exprToRhs :: RhsDemand -> StgExpr -> StgRhs
exprToRhs dem (StgLet (StgNonRec var1 rhs) (StgApp var2 []))
| var1 == var2
= rhs
noSRT -- figure out later
bOGUS_FVs
(if isOnceDem dem then SingleEntry else Updatable)
+ -- HA! Paydirt for "dem"
[]
expr
isDynName nm =
not (isLocallyDefinedName nm) &&
isDynamicModule (nameModule nm)
-
-
\end{code}
\begin{code}
coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg])
--- arguments are all value arguments (tyargs already removed), paired with their demand
+-- Arguments are all value arguments (tyargs already removed), paired with their demand
coreArgsToStg env []
= returnUs ([], [])
coreArgsToStg env ads `thenUs` \ (bs2, as') ->
returnUs (bs1 ++ bs2, a' : as')
--- This is where we arrange that a non-trivial argument is let-bound
coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
+-- This is where we arrange that a non-trivial argument is let-bound
coreArgToStg env (arg,dem)
- = let
- ty = coreExprType arg
- dem' = if isUnLiftedType ty -- if it's unlifted, it's definitely strict
- then dem { isStrictDem = True }
- else dem
- in
- coreExprToStgFloat env arg dem' `thenUs` \ (binds, arg') ->
+ | isStrictDem dem || isUnLiftedType arg_ty
+ -- Strict, so float all the binds out
+ = coreExprToStgFloat env arg dem `thenUs` \ (binds, arg') ->
+ case arg' of
+ StgCon con [] _ | isWHNFCon con -> returnUs (binds, StgConArg con)
+ StgApp v [] -> returnUs (binds, StgVarArg v)
+ other -> newStgVar arg_ty `thenUs` \ v ->
+ returnUs (binds ++ [NonRecF v arg' dem], StgVarArg v)
+ | otherwise
+ -- Lazy
+ = coreExprToStgFloat env arg dem `thenUs` \ (binds, arg') ->
case (binds, arg') of
([], StgCon con [] _) | isWHNFCon con -> returnUs ([], StgConArg con)
([], StgApp v []) -> returnUs ([], StgVarArg v)
- -- A non-trivial argument: we must let (or case-bind)
- -- We don't do the case part here... we leave that to mkStgBinds
-
- -- Further complication: if we're converting this binding into
- -- a case, then try to avoid generating any case-of-case
- -- expressions by pulling out the floats.
- (_, other) ->
- newStgVar ty `thenUs` \ v ->
- if isStrictDem dem'
- then returnUs (binds ++ [StgFloatBind v arg' dem'], StgVarArg v)
- else returnUs ([StgFloatBind v (mkStgBinds binds arg') dem'], StgVarArg v)
+ -- A non-trivial argument: we must let-bind it
+ -- We don't do the case part here... we leave that to mkStgLets
+ (_, other) -> newStgVar arg_ty `thenUs` \ v ->
+ returnUs ([NonRecF v (mkStgBinds binds arg') dem], StgVarArg v)
+ where
+ arg_ty = coreExprType arg
\end{code}
\begin{code}
coreExprToStg :: StgEnv -> CoreExpr -> RhsDemand -> UniqSM StgExpr
+coreExprToStg env expr dem
+ = coreExprToStgFloat env expr dem `thenUs` \ (binds,stg_expr) ->
+ returnUs (mkStgBinds binds stg_expr)
+\end{code}
-coreExprToStg env (Var var) dem
- = returnUs (StgApp (stgLookup env var) [])
+%************************************************************************
+%* *
+\subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
+%* *
+%************************************************************************
+\begin{code}
+coreExprToStgFloat :: StgEnv -> CoreExpr
+ -> RhsDemand
+ -> UniqSM ([StgFloatBind], StgExpr)
+-- Transform an expression to STG. The demand on the expression is
+-- given by RhsDemand, and is solely used ot figure out the usage
+-- of constructor args: if the constructor is used once, then so are
+-- its arguments. The strictness info in RhsDemand isn't used.
+\end{code}
+
+Simple cases first
+
+\begin{code}
+coreExprToStgFloat env (Var var) dem
+ = returnUs ([], StgApp (stgLookup env var) [])
+
+coreExprToStgFloat env (Let bind body) dem
+ = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) ->
+ coreExprToStgFloat new_env body dem `thenUs` \ (floats, stg_body) ->
+ returnUs (new_bind:floats, stg_body)
\end{code}
+Covert core @scc@ expression directly to STG @scc@ expression.
+
+\begin{code}
+coreExprToStgFloat env (Note (SCC cc) expr) dem
+ = coreExprToStg env expr dem `thenUs` \ stg_expr ->
+ returnUs ([], StgSCC cc stg_expr)
+
+coreExprToStgFloat env (Note other_note expr) dem
+ = coreExprToStgFloat env expr dem
+\end{code}
+
+\begin{code}
+coreExprToStgFloat env expr@(Type _) dem
+ = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
+\end{code}
+
+
%************************************************************************
%* *
\subsubsection[coreToStg-lambdas]{Lambda abstractions}
%************************************************************************
\begin{code}
-coreExprToStg env expr@(Lam _ _) dem
+coreExprToStgFloat env expr@(Lam _ _) dem
= let
(binders, body) = collectBinders expr
id_binders = filter isId binders
body_dem = trace "coreExprToStg: approximating body_dem in Lam"
safeDem
in
- newLocalIds env id_binders `thenUs` \ (env', binders') ->
- coreExprToStg env' body body_dem `thenUs` \ stg_body ->
+ newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') ->
+ coreExprToStg env' body body_dem `thenUs` \ stg_body ->
- if null id_binders then -- it was all type/usage binders; tossed
- returnUs stg_body
+ if null id_binders then -- It was all type/usage binders; tossed
+ returnUs ([], stg_body)
else
case stg_body of
(StgLet (StgNonRec var (StgRhsClosure cc bi srt fvs uf args body))
(StgApp var' []))
| var == var' ->
- returnUs (StgLet (StgNonRec var
- (StgRhsClosure noCCS
- stgArgOcc
- noSRT
- bOGUS_FVs
- ReEntrant
- (binders' ++ args)
- body))
- (StgApp var []))
+ returnUs ([],
+ -- ToDo: make this a float, but we need
+ -- a lambda form for that! Sigh
+ StgLet (StgNonRec var (StgRhsClosure noCCS
+ stgArgOcc
+ noSRT
+ bOGUS_FVs
+ ReEntrant
+ (binders' ++ args)
+ body))
+ (StgApp var []))
other ->
-- We must let-bind the lambda
newStgVar (coreExprType expr) `thenUs` \ var ->
- returnUs
- (StgLet (StgNonRec var (StgRhsClosure noCCS
+ returnUs ([],
+ -- Ditto
+ StgLet (StgNonRec var (StgRhsClosure noCCS
stgArgOcc
noSRT
bOGUS_FVs
ReEntrant -- binders is non-empty
binders'
stg_body))
- (StgApp var []))
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
-%* *
-%************************************************************************
-
-\begin{code}
-coreExprToStg env (Let bind body) dem
- = coreBindToStg env bind `thenUs` \ (stg_binds, new_env) ->
- coreExprToStg new_env body dem `thenUs` \ stg_body ->
- returnUs (foldr StgLet stg_body stg_binds)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection[coreToStg-scc]{SCC expressions}
-%* *
-%************************************************************************
-
-Covert core @scc@ expression directly to STG @scc@ expression.
-\begin{code}
-coreExprToStg env (Note (SCC cc) expr) dem
- = coreExprToStg env expr dem `thenUs` \ stg_expr ->
- returnUs (StgSCC cc stg_expr)
-\end{code}
-
-\begin{code}
-coreExprToStg env (Note other_note expr) dem = coreExprToStg env expr dem
-\end{code}
-
-The rest are handled by coreExprStgFloat.
-
-\begin{code}
-coreExprToStg env expr dem
- = coreExprToStgFloat env expr dem `thenUs` \ (binds,stg_expr) ->
- returnUs (mkStgBinds binds stg_expr)
+ (StgApp var []))
\end{code}
%************************************************************************
\begin{code}
coreExprToStgFloat env expr@(App _ _) dem
= let
- (fun,rads,_) = collect_args expr
- ads = reverse rads
+ (fun,rads,_,_) = collect_args expr
+ ads = reverse rads
in
coreArgsToStg env ads `thenUs` \ (binds, stg_args) ->
(Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
-- there are no arguments.
returnUs (binds,
- StgApp (stgLookup env fun_id) stg_args)
+ StgApp (stgLookup env fun_id) stg_args)
(non_var_fun, []) -> -- No value args, so recurse into the function
ASSERT( null binds )
- coreExprToStg env non_var_fun dem `thenUs` \e ->
- returnUs ([], e)
+ coreExprToStgFloat env non_var_fun dem
other -> -- A non-variable applied to things; better let-bind it.
newStgVar (coreExprType fun) `thenUs` \ fun_id ->
- coreRhsToStg env fun onceDem `thenUs` \ fun_rhs ->
- returnUs (binds,
- StgLet (StgNonRec fun_id fun_rhs) $
+ coreExprToStg env fun onceDem `thenUs` \ stg_fun ->
+ returnUs (NonRecF fun_id stg_fun onceDem : binds,
StgApp fun_id stg_args)
+
where
-- Collect arguments and demands (*in reverse order*)
- collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type)
- collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty) = collect_args fun
- in (the_fun,ads,applyTy fun_ty tyarg)
- collect_args (App fun arg ) = let (the_fun,ads,fun_ty) = collect_args fun
- (arg_ty,res_ty) = expectJust "coreExprToStgFloat:collect_args" $
- splitFunTy_maybe fun_ty
- in (the_fun,(arg,tyDem arg_ty):ads,res_ty)
- collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_ ) = collect_args e
- in (the_fun,ads,ty)
+ -- collect_args e = (f, args_w_demands, ty, stricts)
+ -- => e = f tys args, (i.e. args are just the value args)
+ -- e :: ty
+ -- stricts is the leftover demands of e on its further args
+ -- If stricts runs out, we zap all the demands in args_w_demands
+ -- because partial applications are lazy
+
+ collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand])
+
+ collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
+ in (the_fun,ads,ty,ss)
collect_args (Note InlineCall e) = collect_args e
collect_args (Note (TermUsg _) e) = collect_args e
- collect_args fun = (fun,[],coreExprType fun)
+
+ collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
+ in (the_fun,ads,applyTy fun_ty tyarg,ss)
+ collect_args (App fun arg)
+ = case ss of
+ [] -> -- Strictness info has run out
+ (the_fun, (arg, mkDemTy wwLazy arg_ty) : zap ads, res_ty, repeat wwLazy)
+ (ss1:ss_rest) -> -- Enough strictness info
+ (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
+ where
+ (the_fun, ads, fun_ty, ss) = collect_args fun
+ (arg_ty, res_ty) = expectJust "coreExprToStgFloat:collect_args" $
+ splitFunTy_maybe fun_ty
+
+ collect_args (Var v)
+ = (Var v, [], idType v, stricts)
+ where
+ stricts = case getIdStrictness v of
+ StrictnessInfo demands _ -> demands
+ other -> repeat wwLazy
+
+ collect_args fun = (fun, [], coreExprType fun, repeat wwLazy)
+
+ -- "zap" nukes the strictness info for a partial application
+ zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
\end{code}
%************************************************************************
%* *
-\subsubsection[coreToStg-con]{Constructors}
+\subsubsection[coreToStg-con]{Constructors and primops}
%* *
%************************************************************************
\begin{code}
coreExprToStgFloat env expr@(Con con args) dem
= let
- args' = filter isValArg args
- dems' = case con of
- Literal _ -> ASSERT( null args' {-'cpp-} )
- []
- DEFAULT -> panic "coreExprToStgFloat: DEFAULT"
- DataCon c -> repeat (if isOnceDem dem then onceDem else safeDem)
- PrimOp p -> let tyargs = map (\ (Type ty) -> ty) $
- takeWhile isTypeArg args
- (arg_tys,_) = primOpUsgTys p tyargs
- in ASSERT( length arg_tys == length args' {-'cpp-} )
- -- primops always fully applied, so == not >=
- map tyDem arg_tys
+ (stricts,_) = conStrictness con
+ onces = case con of
+ DEFAULT -> panic "coreExprToStgFloat: DEFAULT"
+
+ Literal _ -> ASSERT( null args' {-'cpp-} ) []
+
+ DataCon c -> repeat (isOnceDem dem)
+ -- HA! This is the sole reason we propagate
+ -- dem all the way down
+
+ PrimOp p -> let tyargs = map (\ (Type ty) -> ty) $
+ takeWhile isTypeArg args
+ (arg_tys,_) = primOpUsgTys p tyargs
+ in ASSERT( length arg_tys == length args' {-'cpp-} )
+ -- primops always fully applied, so == not >=
+ map isOnceTy arg_tys
+
+ dems' = zipWith mkDem stricts onces
+ args' = filter isValArg args
in
coreArgsToStg env (zip args' dems') `thenUs` \ (binds, stg_atoms) ->
- (case con of -- must change unique if present
+
+ -- YUK YUK: must unique if present
+ (case con of
PrimOp (CCallOp (Right _) a b c) -> getUniqueUs `thenUs` \ u ->
returnUs (PrimOp (CCallOp (Right u) a b c))
- _ -> returnUs con)
- `thenUs` \ con' ->
+ _ -> returnUs con
+ ) `thenUs` \ con' ->
+
returnUs (binds, StgCon con' stg_atoms (coreExprType expr))
\end{code}
+
%************************************************************************
%* *
\subsubsection[coreToStg-cases]{Case expressions}
%************************************************************************
\begin{code}
-coreExprToStgFloat env expr@(Case scrut bndr alts) dem
+coreExprToStgFloat env (Case scrut bndr alts) dem
= coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') ->
newEvaldLocalId env bndr `thenUs` \ (env', bndr') ->
alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
-- (hack for old code gen)
\end{code}
-\begin{code}
-coreExprToStgFloat env expr@(Type _) dem
- = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
-\end{code}
-
-\begin{code}
-coreExprToStgFloat env expr dem
- = coreExprToStg env expr dem `thenUs` \stg_expr ->
- returnUs ([], stg_expr)
-\end{code}
%************************************************************************
%* *
\end{code}
\begin{code}
-newLocalId env id
- | externallyVisibleId id
- = returnUs (env, id)
+-- we overload the demandInfo field of an Id to indicate whether the Id is definitely
+-- evaluated or not (i.e. whether it is a case binder). This can be used to eliminate
+-- some redundant cases (c.f. dataToTag# above).
- | otherwise
- = -- Local binder, give it a new unique Id.
- getUniqueUs `thenUs` \ uniq ->
+newEvaldLocalId env id
+ = getUniqueUs `thenUs` \ uniq ->
let
- id' = setIdUnique id uniq
+ id' = modifyIdInfo (`setDemandInfo` wwStrict) (setIdUnique id uniq)
new_env = extendVarEnv env id id'
in
returnUs (new_env, id')
--- we overload the demandInfo field of an Id to indicate whether the Id is definitely
--- evaluated or not (i.e. whether it is a case binder). This can be used to eliminate
--- some redundant cases (c.f. dataToTag# above).
-newEvaldLocalId env id
- = getUniqueUs `thenUs` \ uniq ->
+newLocalId TopLevel env id
+ = returnUs (env, id)
+ -- Don't clone top-level binders. MkIface relies on their
+ -- uniques staying the same, so it can snaffle IdInfo off the
+ -- STG ids to put in interface files.
+
+newLocalId NotTopLevel env id
+ = -- Local binder, give it a new unique Id.
+ getUniqueUs `thenUs` \ uniq ->
let
- id' = setIdUnique id uniq `modifyIdInfo` setDemandInfo wwStrict
+ id' = setIdUnique id uniq
new_env = extendVarEnv env id id'
in
returnUs (new_env, id')
-newLocalIds :: StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
-newLocalIds env []
+newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
+newLocalIds top_lev env []
= returnUs (env, [])
-newLocalIds env (b:bs)
- = newLocalId env b `thenUs` \ (env', b') ->
- newLocalIds env' bs `thenUs` \ (env'', bs') ->
+newLocalIds top_lev env (b:bs)
+ = newLocalId top_lev env b `thenUs` \ (env', b') ->
+ newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
returnUs (env'', b':bs')
\end{code}
mkStgBinds :: [StgFloatBind] -> StgExpr -> StgExpr
mkStgBinds binds body = foldr mkStgBind body binds
-mkStgBind (StgFloatBind bndr rhs dem) body
- | isUnLiftedType bndr_ty
- = ASSERT( not ((isUnboxedTupleType bndr_ty) && (isStrictDem dem==False)) )
+mkStgBind NoBindF body = body
+mkStgBind (RecF prs) body = StgLet (StgRec prs) body
+
+mkStgBind (NonRecF bndr rhs dem) body
+#ifdef DEBUG
+ -- We shouldn't get let or case of the form v=w
+ = case rhs of
+ StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
+ (mk_stg_let bndr rhs dem body)
+ other -> mk_stg_let bndr rhs dem body
+
+mk_stg_let bndr rhs dem body
+#endif
+ | isUnLiftedType bndr_ty -- Use a case/PrimAlts
+ = ASSERT( not (isUnboxedTupleType bndr_ty) )
mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
- | isStrictDem dem == True -- case
+ | isStrictDem dem && not_whnf -- Use an case/AlgAlts
= mkStgCase rhs bndr (StgAlgAlts bndr_ty [] (StgBindDefault body))
- | isStrictDem dem == False -- let
- = StgLet (StgNonRec bndr (exprToRhs dem rhs)) body
+ | otherwise
+ = ASSERT( not (isUnLiftedType bndr_ty) )
+ StgLet (StgNonRec bndr expr_rhs) body
where
bndr_ty = idType bndr
+ expr_rhs = exprToRhs dem rhs
+ not_whnf = case expr_rhs of
+ StgRhsClosure _ _ _ _ _ args _ -> null args
+ StgRhsCon _ _ _ -> False
mkStgCase (StgLet bind expr) bndr alts
= StgLet bind (mkStgCase expr bndr alts)
(Nothing, strictness_info, _) ->
- -- Includes MagicUnfolding, NoUnfolding
+ -- Includes NoUnfolding
-- Try the strictness info
absValFromStrictness anal strictness_info
\end{code}
#include "HsVersions.h"
-import CmdLineOpts ( opt_D_dump_stranal, opt_D_simplifier_stats, opt_D_verbose_core2core )
+import CmdLineOpts ( opt_D_dump_stranal, opt_D_dump_simpl_stats, opt_D_verbose_core2core )
import CoreSyn
import Id ( idType, setIdStrictness,
getIdDemandInfo, setIdDemandInfo,
-- Mark each binder with its strictness
#ifndef OMIT_STRANAL_STATS
let { (binds_w_strictness, sa_stats) = saTopBinds binds nullSaStats };
- dumpIfSet opt_D_simplifier_stats "Strictness analysis statistics"
+ dumpIfSet opt_D_dump_simpl_stats "Strictness analysis statistics"
(pp_stats sa_stats);
#else
let { binds_w_strictness = saTopBindsBinds binds };
-> Id -- Augmented with strictness
addStrictnessInfoToId str_val abs_val binder body
- = case (collectTyAndValBinders body) of
- (_, lambda_bounds, rhs) -> binder `setIdStrictness`
- mkStrictnessInfo strictness
+ = case collectBinders body of
+ -- We could use 'collectBindersIgnoringNotes', but then the
+ -- strictness info may have more items than the visible binders
+ -- used by WorkWrap.tryWW
+ (binders, rhs) -> binder `setIdStrictness`
+ mkStrictnessInfo strictness
where
- tys = map idType lambda_bounds
+ tys = [idType id | id <- binders, isId id]
strictness = findStrictness tys str_val abs_val
\end{code}
\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
\begin{code}
-module WorkWrap ( wwTopBinds, getWorkerIdAndCons ) where
+module WorkWrap ( wwTopBinds, getWorkerId ) where
#include "HsVersions.h"
import CoreSyn
import CoreUnfold ( Unfolding, certainlySmallEnoughToInline, calcUnfoldingGuidance )
-import CmdLineOpts ( opt_UnfoldingCreationThreshold, opt_D_verbose_core2core,
- opt_D_dump_worker_wrapper )
+import CmdLineOpts ( opt_UF_CreationThreshold , opt_D_verbose_core2core,
+ opt_D_dump_worker_wrapper
+ )
import CoreLint ( beginPass, endPass )
import CoreUtils ( coreExprType )
import Const ( Con(..) )
import DataCon ( DataCon )
import MkId ( mkWorkerId )
-import Id ( Id, getIdStrictness,
- setIdStrictness, setInlinePragma, idWantsToBeINLINEd,
+import Id ( Id, getIdStrictness, setIdArity,
+ setIdStrictness,
setIdWorkerInfo, getIdCprInfo )
import VarSet
import Type ( splitAlgTyConApp_maybe )
import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..),
- InlinePragInfo(..), CprInfo(..) )
+ CprInfo(..), exactArity
+ )
import Demand ( wwLazy )
import SaLib
import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
-- if two, then a worker and a
-- wrapper.
tryWW non_rec fn_id rhs
- | idWantsToBeINLINEd fn_id
- || (non_rec && -- Don't split if its non-recursive and small
- certainlySmallEnoughToInline fn_id unfold_guidance
+ | (non_rec && -- Don't split if its non-recursive and small
+ certainlySmallEnoughToInline unfold_guidance
)
-- No point in worker/wrappering something that is going to be
-- INLINEd wholesale anyway. If the strictness analyser is run
let
work_rhs = work_fn body
work_id = mkWorkerId work_uniq fn_id (coreExprType work_rhs) `setIdStrictness`
- (if do_strict_ww then mkStrictnessInfo (work_demands, result_bot)
- else noStrictnessInfo)
+ (if has_strictness_info then mkStrictnessInfo (work_demands, result_bot)
+ else noStrictnessInfo)
wrap_rhs = wrap_fn work_id
wrap_id = fn_id `setIdStrictness`
- (if do_strict_ww then mkStrictnessInfo (revised_wrap_args_info, result_bot)
- else noStrictnessInfo)
- `setIdWorkerInfo` (Just work_id)
- `setInlinePragma` IWantToBeINLINEd
+ (if has_strictness_info then mkStrictnessInfo (revised_wrap_args_info, result_bot)
+ else noStrictnessInfo)
+ `setIdWorkerInfo` Just work_id
+ `setIdArity` exactArity (length wrap_args)
-- Add info to the wrapper:
-- (a) we want to inline it everywhere
-- (b) we want to pin on its revised strictness info
then setUnpackStrategy wrap_args_info
else repeat wwLazy
-
- -- If we are going to split for CPR purposes anyway, then
- -- we may as well do the strictness transformation
- do_strict_ww = has_strictness_info && (do_cpr_ww ||
- worthSplitting revised_wrap_args_info)
+ do_strict_ww = has_strictness_info && worthSplitting revised_wrap_args_info result_bot
cpr_info = getIdCprInfo fn_id
has_cpr_info = case cpr_info of
- CPRInfo _ -> True
- other -> False
+ CPRInfo _ -> True
+ other -> False
do_cpr_ww = has_cpr_info
-
- unfold_guidance = calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
+ unfold_guidance = calcUnfoldingGuidance opt_UF_CreationThreshold rhs
-- This rather (nay! extremely!) crude function looks at a wrapper function, and
--- snaffles out (a) the worker Id and (b) constructors needed to
--- make the wrapper.
--- These are needed when we write an interface file.
+-- snaffles out the worker Id from the wrapper.
+-- This is needed when we write an interface file.
+-- [May 1999: we used to get the constructors too, but that's no longer
+-- necessary, because the renamer hauls in all type decls in
+-- their fullness.]
-- <Mar 1999 (keving)> - Well, since the addition of the CPR transformation this function
-- got too crude!
-- Now the worker id is stored directly in the id's Info field. We still use this function to
-- snaffle the wrapper's constructors but I don't trust the code to find the worker id.
-getWorkerIdAndCons :: Id -> CoreExpr -> (Id, UniqSet DataCon)
-getWorkerIdAndCons wrap_id wrapper_fn
- = (work_id wrapper_fn, get_cons wrapper_fn)
+getWorkerId :: Id -> CoreExpr -> Id
+getWorkerId wrap_id wrapper_fn
+ = work_id wrapper_fn
where
work_id wrapper_fn
= case get_work_id wrapper_fn of
[] -> case work_id_try2 wrapper_fn of
- [] -> pprPanic "getWorkerIdAndCons: can't find worker id" (ppr wrap_id)
+ [] -> pprPanic "getWorkerId: can't find worker id" (ppr wrap_id)
[id] -> id
- _ -> pprPanic "getWorkerIdAndCons: found too many worker ids" (ppr wrap_id)
+ _ -> pprPanic "getWorkerId: found too many worker ids" (ppr wrap_id)
[id] -> id
- _ -> pprPanic "getWorkerIdAndCons: found too many worker ids" (ppr wrap_id)
+ _ -> pprPanic "getWorkerId: found too many worker ids" (ppr wrap_id)
get_work_id (Lam _ body) = get_work_id body
get_work_id (Case _ _ [(_,_,rhs@(Case _ _ _))]) = get_work_id rhs
work_id_try2 (App fn _) = work_id_try2 fn
work_id_try2 (Var work_id) = [work_id]
work_id_try2 other = []
-
- get_cons (Lam _ body) = get_cons body
- get_cons (Let (NonRec _ rhs) body) = get_cons rhs `unionUniqSets` get_cons body
-
- get_cons (Case e _ [(DataCon dc,_,rhs)]) = (get_cons e `unionUniqSets` get_cons rhs)
- `addOneToUniqSet` dc
-
- -- Coercions don't mention the construtor now,
- -- but we must still put the constructor in the interface
- -- file so that the RHS of the newtype decl is imported
- get_cons (Note (Coerce to_ty from_ty) body)
- = get_cons body `addOneToUniqSet` con
- where
- con = case splitAlgTyConApp_maybe from_ty of
- Just (_, _, [con]) -> con
- other -> pprPanic "getWorkerIdAndCons" (ppr to_ty)
-
- get_cons other = emptyUniqSet
\end{code}
import Const ( Con(..), DataCon )
import DataCon ( dataConArgTys )
import Demand ( Demand(..) )
-import PrelVals ( aBSENT_ERROR_ID )
-import TysWiredIn ( unitTy, unitDataCon,
- unboxedTupleCon, unboxedTupleTyCon )
+import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID )
+import TysPrim ( realWorldStatePrimTy )
+import TysWiredIn ( unboxedTupleCon, unboxedTupleTyCon )
import Type ( isUnLiftedType, mkTyVarTys, mkTyVarTy, mkFunTys,
- splitForAllTys, splitFunTys,
+ splitForAllTys, splitFunTysN,
splitAlgTyConApp_maybe, mkTyConApp,
Type
)
nonAbsentArgs (WwLazy True : ds) = nonAbsentArgs ds
nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds
-worthSplitting :: [Demand] -> Bool -- True <=> the wrapper would not be an identity function
-worthSplitting ds = any worth_it ds
+worthSplitting :: [Demand]
+ -> Bool -- Result is bottom
+ -> Bool -- True <=> the wrapper would not be an identity function
+worthSplitting ds result_bot = not result_bot && any worth_it ds
+ -- Don't split if the result is bottom; there's no efficiency to
+ -- be gained, and (worse) the wrapper body may not look like a wrapper
+ -- body to getWorkerIdAndCons
where
worth_it (WwLazy True) = True -- Absent arg
worth_it (WwUnpack _ True _) = True -- Arg to unpack
\begin{code}
mkWrapper :: Type -- Wrapper type
+ -> Int -- Arity
-> [Demand] -- Wrapper strictness info
-> CprInfo -- Wrapper cpr info
-> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id
-mkWrapper fun_ty demands cpr_info
- = let
- n_wrap_args = length demands
- in
- getUniquesUs n_wrap_args `thenUs` \ wrap_uniqs ->
+mkWrapper fun_ty arity demands cpr_info
+ = getUniquesUs arity `thenUs` \ wrap_uniqs ->
let
(tyvars, tau_ty) = splitForAllTys fun_ty
- (arg_tys, body_ty) = splitFunTys tau_ty
+ (arg_tys, body_ty) = splitFunTysN "mkWrapper" arity tau_ty
-- The "expanding dicts" part here is important, even for the splitForAll
-- The imported thing might be a dictionary, such as Functor Foo
-- But Functor Foo = forall a b. (a->b) -> Foo a -> Foo b
-- and as such might have some strictness info attached.
-- Then we need to have enough args to zip to the strictness info
- wrap_args = ASSERT( n_wrap_args <= length arg_tys )
- zipWith mk_ww_local wrap_uniqs arg_tys
-
- leftover_arg_tys = drop n_wrap_args arg_tys
- final_body_ty = mkFunTys leftover_arg_tys body_ty
+ wrap_args = zipWith mk_ww_local wrap_uniqs arg_tys
in
- mkWwBodies tyvars wrap_args final_body_ty demands cpr_info `thenUs` \ (wrap_fn, _, _) ->
+ mkWwBodies tyvars wrap_args body_ty demands cpr_info `thenUs` \ (wrap_fn, _, _) ->
returnUs wrap_fn
\end{code}
-- f = /\abc. \xyz. fw abc void
-- fw = /\abc. \v. body
--
+ -- We use the state-token type which generates no code
getUniqueUs `thenUs` \ void_arg_uniq ->
let
- void_arg = mk_ww_local void_arg_uniq unitTy
+ void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy
in
- returnUs (\ work_id -> mkLams tyvars $ mkLams args $
+ returnUs (\ work_id -> Note InlineMe $ -- Inline the wrapper
+ mkLams tyvars $ mkLams args $
mkApps (Var work_id)
- (map (Type . mkTyVarTy) tyvars ++ [mkConApp unitDataCon []]),
+ (map (Type . mkTyVarTy) tyvars ++ [Var realWorldPrimId]),
\ body -> mkLams (tyvars ++ [void_arg]) body,
[WwLazy True])
wrap_args_w_demands = zipWith setIdDemandInfo wrap_args demands
in
mkWW wrap_args_w_demands `thenUs` \ (wrap_fn, work_args_w_demands, work_fn) ->
- mkWWcpr body_ty cpr_info
- `thenUs` \ (wrap_fn_w_cpr, work_fn_w_cpr) ->
- returnUs (\ work_id -> mkLams tyvars $ mkLams wrap_args_w_demands $
+
+ mkWWcpr body_ty cpr_info `thenUs` \ (wrap_fn_w_cpr, work_fn_w_cpr) ->
+
+ returnUs (\ work_id -> Note InlineMe $
+ mkLams tyvars $ mkLams wrap_args_w_demands $
(wrap_fn_w_cpr . wrap_fn) (mkTyApps (Var work_id) (mkTyVarTys tyvars)),
\ body -> mkLams tyvars $ mkLams work_args_w_demands $
\begin{code}
-
-mkWWcpr :: Type -- function body type
- -> CprInfo -- CPR analysis results
- -> UniqSM (CoreExpr -> CoreExpr, -- New wrapper
- CoreExpr -> CoreExpr) -- New worker
+mkWWcpr :: Type -- function body type
+ -> CprInfo -- CPR analysis results
+ -> UniqSM (CoreExpr -> CoreExpr, -- New wrapper
+ CoreExpr -> CoreExpr) -- New worker
mkWWcpr body_ty NoCPRInfo
= returnUs (id, id) -- Must be just the strictness transf.
cpr_reconstruct body_ty cpr_info' `thenUs` \reconst_fn ->
cpr_flatten body_ty cpr_info' `thenUs` \flatten_fn ->
returnUs (reconst_fn, flatten_fn)
- -- We only make use of the outer level of CprInfo, otherwise we
- -- may lose laziness. :-( Hopefully, we will find a use for the
- -- extra info some day (e.g. creating versions specialized to
- -- the use made of the components of the result by the callee)
- where cpr_info' = CPRInfo (map (const NoCPRInfo) cpr_args)
+ where
+ -- We only make use of the outer level of CprInfo, otherwise we
+ -- may lose laziness. :-( Hopefully, we will find a use for the
+ -- extra info some day (e.g. creating versions specialized to
+ -- the use made of the components of the result by the callee)
+ cpr_info' = CPRInfo (map (const NoCPRInfo) cpr_args)
\end{code}
These are returned in an unboxed tuple.
\begin{code}
-
cpr_flatten :: Type -> CprInfo -> UniqSM (CoreExpr -> CoreExpr)
cpr_flatten ty cpr_info
= mk_cpr_case (ty, cpr_info) `thenUs` \(res_id, tup_ids, flatten_exp) ->
mk_cpr_let (ty, NoCPRInfo)
-- this component will appear explicitly in the unboxed tuple.
= getUniqueUs `thenUs` \id_uniq ->
- let id_id = mk_ww_local id_uniq ty in
- returnUs (id_id, [id_id], id)
+ let
+ id_id = mk_ww_local id_uniq ty
+ in
+ returnUs (id_id, [id_id], id)
+
mk_cpr_let (ty, cpr_info@(CPRInfo ci_args))
| isNewTyCon tycon -- a new type: must coerce the argument to this type
= ASSERT ( null $ tail inst_con_arg_tys )
Nothing ->
pprPanic (fname ++ ":")
(text "not a datatype" $$ ppr ty)
-
-
\end{code}
+
%************************************************************************
%* *
\subsection{Utilities}
InstanceMapper,
newDictFromOld, newDicts, newDictsAtLoc,
- newMethod, newMethodWithGivenTy, newOverloadedLit,
+ newMethod, newMethodWithGivenTy, newOverloadedLit, instOverloadedFun,
tyVarsOfInst, instLoc, getDictClassTys,
zonkTcThetaType
)
import Bag
-import Class ( classInstEnv,
- Class, ClassInstEnv
- )
+import Class ( classInstEnv, Class )
import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
import VarSet ( elemVarSet )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName )
import PprType ( pprConstraint )
-import SpecEnv ( SpecEnv, lookupSpecEnv )
+import InstEnv ( InstEnv, lookupInstEnv )
import SrcLoc ( SrcLoc )
-import Type ( Type, ThetaType, substTy,
- isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy,
+import Type ( Type, ThetaType,
+ mkTyVarTy, isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy,
splitRhoTy, tyVarsOfType, tyVarsOfTypes,
- mkSynTy, substTopTy, substTopTheta,
- tidyOpenType, tidyOpenTypes
+ mkSynTy, tidyOpenType, tidyOpenTypes
+ )
+import InstEnv ( InstEnv )
+import Subst ( emptyInScopeSet, mkSubst,
+ substTy, substTheta, mkTyVarSubst, mkTopTyVarSubst
)
import TyCon ( TyCon )
-import VarEnv ( zipVarEnv, lookupVarEnv, TidyEnv )
+import Subst ( mkTyVarSubst )
+import VarEnv ( lookupVarEnv, TidyEnv,
+ lookupSubstEnv, SubstResult(..)
+ )
import VarSet ( unionVarSet )
import TysPrim ( intPrimTy, floatPrimTy, doublePrimTy )
import TysWiredIn ( intDataCon, isIntTy, inIntRange,
zonkLIE lie = mapBagNF_Tc zonkInst lie
pprInsts :: [Inst] -> SDoc
-pprInsts insts = parens (hsep (punctuate comma (map pprInst insts)))
+pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
pprInstsInFull insts
= -- Get the Id type and instantiate it at the specified types
let
(tyvars, rho) = splitForAllTys (idType id)
- rho_ty = substTy (zipVarEnv tyvars tys) rho
- (theta, tau) = splitRhoTy rho_ty
+ rho_ty = substTy (mkTyVarSubst tyvars tys) rho
+ (theta, tau) = splitRhoTy rho_ty
in
newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst ->
returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
+instOverloadedFun orig (HsVar v) arg_tys theta tau
+ = newMethodWithGivenTy orig v arg_tys theta tau `thenNF_Tc` \ inst ->
+ returnNF_Tc (HsVar (instToId inst), unitLIE inst)
newMethodWithGivenTy orig id tys theta tau
= tcGetSrcLoc `thenNF_Tc` \ loc ->
let
(tyvars,rho) = splitForAllTys (idType real_id)
rho_ty = ASSERT( length tyvars == length tys )
- substTopTy (zipVarEnv tyvars tys) rho
+ substTy (mkTopTyVarSubst tyvars tys) rho
(theta, tau) = splitRhoTy rho_ty
meth_inst = Method new_uniq real_id tys theta tau orig loc
in
%************************************************************************
\begin{code}
-type InstanceMapper = Class -> ClassInstEnv
+type InstanceMapper = Class -> InstEnv
\end{code}
A @ClassInstEnv@ lives inside a class, and identifies all the instances
-- Dictionaries
lookupInst dict@(Dict _ clas tys orig loc)
- = case lookupSpecEnv (ppr clas) (classInstEnv clas) tys of
+ = case lookupInstEnv (ppr clas) (classInstEnv clas) tys of
Just (tenv, dfun_id)
-> let
+ subst = mkSubst (tyVarsOfTypes tys) tenv
(tyvars, rho) = splitForAllTys (idType dfun_id)
- ty_args = map (expectJust "Inst" . lookupVarEnv tenv) tyvars
- -- tenv should bind all the tyvars
- dfun_rho = substTopTy tenv rho
+ ty_args = map subst_tv tyvars
+ dfun_rho = substTy subst rho
(theta, tau) = splitRhoTy dfun_rho
ty_app = mkHsTyApp (HsVar dfun_id) ty_args
+ subst_tv tv = case lookupSubstEnv tenv tv of
+ Just (DoneTy ty) -> ty
+ -- tenv should bind all the tyvars
in
if null theta then
returnNF_Tc (SimpleInst ty_app)
ambiguous dictionaries.
\begin{code}
-lookupSimpleInst :: ClassInstEnv
+lookupSimpleInst :: InstEnv
-> Class
-> [Type] -- Look up (c,t)
-> NF_TcM s (Maybe ThetaType) -- Here are the needed (c,t)s
lookupSimpleInst class_inst_env clas tys
- = case lookupSpecEnv (ppr clas) class_inst_env tys of
+ = case lookupInstEnv (ppr clas) class_inst_env tys of
Nothing -> returnNF_Tc Nothing
Just (tenv, dfun)
- -> returnNF_Tc (Just (substTopTheta tenv theta))
+ -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
where
(_, theta, _) = splitSigmaTy (idType dfun)
\end{code}
\begin{code}
module TcBinds ( tcBindsAndThen, tcTopBindsAndThen,
- tcPragmaSigs, tcBindWithSigs ) where
+ tcSpecSigs, tcBindWithSigs ) where
#include "HsVersions.h"
newDicts, tyVarsOfInst, instToId,
)
import TcEnv ( tcExtendLocalValEnv,
- newSpecPragmaId,
+ newSpecPragmaId, newLocalId,
tcLookupTyCon,
tcGetGlobalTyVars, tcExtendGlobalTyVars
)
import TcMonoType ( tcHsType, checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
-import TcPat ( tcVarPat, tcPat )
+import TcPat ( tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
import TcType ( TcType, TcThetaType,
TcTyVar,
import PrelInfo ( main_NAME, ioTyCon_NAME )
-import Id ( mkUserId )
-import Var ( idType, idName, setIdInfo )
-import IdInfo ( IdInfo, noIdInfo, setInlinePragInfo, InlinePragInfo(..) )
-import Name ( Name, getName )
+import Id ( Id, mkVanillaId, setInlinePragma )
+import Var ( idType, idName )
+import IdInfo ( IdInfo, vanillaIdInfo, setInlinePragInfo, InlinePragInfo(..) )
+import Name ( Name, getName, getOccName, getSrcLoc )
+import NameSet
import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
splitSigmaTy, mkForAllTys, mkFunTys, getTyVar,
mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType,
import Bag
import Util ( isIn )
import Maybes ( maybeToBool )
-import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
+import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNotTopLevel )
import SrcLoc ( SrcLoc )
import Outputable
\end{code}
do_next
tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
- = fixTc (\ ~(prag_info_fn, _, _) ->
- -- This is the usual prag_info fix; the PragmaInfo field of an Id
- -- is not inspected till ages later in the compiler, so there
- -- should be no black-hole problems here.
-
- -- TYPECHECK THE SIGNATURES
+ = -- TYPECHECK THE SIGNATURES
mapTc tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenTc` \ tc_ty_sigs ->
- tcBindWithSigs top_lvl bind
- tc_ty_sigs is_rec prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
+ tcBindWithSigs top_lvl bind tc_ty_sigs
+ sigs is_rec `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
-- Extend the environment to bind the new polymorphic Ids
tcExtendLocalValEnv [(idName poly_id, poly_id) | poly_id <- poly_ids] $
-- Build bindings and IdInfos corresponding to user pragmas
- tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
+ tcSpecSigs sigs `thenTc` \ (prag_binds, prag_lie) ->
-- Now do whatever happens next, in the augmented envt
do_next `thenTc` \ (thing, thing_lie) ->
-- All the top level things are rec'd together anyway, so it's fine to
-- leave them to the tcSimplifyTop, and quite a bit faster too
(TopLevel, _)
- -> returnTc (prag_info_fn,
- combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing,
+ -> returnTc (combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing,
thing_lie `plusLIE` prag_lie `plusLIE` poly_lie)
(NotTopLevel, NonRecursive)
poly_ids `thenTc` \ (thing_lie', lie_binds) ->
returnTc (
- prag_info_fn,
combiner NonRecursive poly_binds $
combiner NonRecursive prag_binds $
combiner Recursive lie_binds $
poly_ids `thenTc` \ (final_lie, lie_binds) ->
returnTc (
- prag_info_fn,
combiner Recursive (
poly_binds `andMonoBinds`
lie_binds `andMonoBinds`
prag_binds) thing,
final_lie
- )
- ) `thenTc` \ (_, thing, lie) ->
- returnTc (thing, lie)
+ )
\end{code}
An aside. The original version of @tcBindsAndThen@ which lacks a
:: TopLevelFlag
-> RenamedMonoBinds
-> [TcSigInfo]
+ -> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs
-> RecFlag
- -> (Name -> IdInfo)
-> TcM s (TcMonoBinds, LIE, [TcId])
-tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn
+tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
= recoverTc (
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise subsequent
poly_ids = map mk_dummy binder_names
mk_dummy name = case maybeSig tc_ty_sigs name of
Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature
- Nothing -> mkUserId name forall_a_a -- No signature
+ Nothing -> mkVanillaId name forall_a_a -- No signature
in
returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
) $
-- TYPECHECK THE BINDINGS
- tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
+ tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
-- CHECK THAT THE SIGNATURES MATCH
-- (must do this before getTyVarsToGen)
(if any isUnLiftedType zonked_mono_id_types then
-- Unlifted bindings must be non-recursive,
-- not top level, and non-polymorphic
- checkTc (case top_lvl of {TopLevel -> False; NotTopLevel -> True})
+ checkTc (isNotTopLevel top_lvl)
(unliftedBindErr "Top-level" mbind) `thenTc_`
checkTc (case is_rec of {Recursive -> False; NonRecursive -> True})
(unliftedBindErr "Recursive" mbind) `thenTc_`
exports = zipWith mk_export binder_names zonked_mono_ids
dict_tys = map idType dicts_bound
+ inlines = mkNameSet [name | InlineSig name loc <- inline_sigs]
+ no_inlines = mkNameSet [name | NoInlineSig name loc <- inline_sigs]
+
mk_export binder_name zonked_mono_id
= (tyvars,
- setIdInfo poly_id (prag_info_fn binder_name),
+ attachNoInlinePrag no_inlines poly_id,
zonked_mono_id)
where
(tyvars, poly_id) =
(sig_tyvars, sig_poly_id)
Nothing -> (real_tyvars_to_gen_list, new_poly_id)
- new_poly_id = mkUserId binder_name poly_ty
+ new_poly_id = mkVanillaId binder_name poly_ty
poly_ty = mkForAllTys real_tyvars_to_gen_list
$ mkFunTys dict_tys
$ idType (zonked_mono_id)
AbsBinds real_tyvars_to_gen_list
dicts_bound
exports
+ inlines
(dict_binds `andMonoBinds` mbind'),
lie_free,
[poly_id | (_, poly_id, _) <- exports]
justPatBindings (AndMonoBinds b1 b2) binds =
justPatBindings b1 (justPatBindings b2 binds)
justPatBindings other_bind binds = binds
+
+attachNoInlinePrag no_inlines bndr
+ | idName bndr `elemNameSet` no_inlines = bndr `setInlinePragma` IMustNotBeINLINEd
+ | otherwise = bndr
\end{code}
Polymorphic recursion
returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids)
where
- sig_fn name = case maybeSig tc_ty_sigs name of
- Nothing -> Nothing
- Just (TySigInfo _ _ _ _ _ mono_id _ _) -> Just mono_id
+
+ -- This function is used when dealing with a LHS binder; we make a monomorphic
+ -- version of the Id. We check for type signatures
+ tc_pat_bndr name pat_ty
+ = case maybeSig tc_ty_sigs name of
+ Nothing
+ -> newLocalId (getOccName name) pat_ty (getSrcLoc name)
+
+ Just (TySigInfo _ _ _ _ _ mono_id _ _)
+ -> tcAddSrcLoc (getSrcLoc name) $
+ unifyTauTy (idType mono_id) pat_ty `thenTc_`
+ returnTc mono_id
mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
Nothing -> (name, mono_id)
tc_mb_pats (FunMonoBind name inf matches locn)
= newTyVarTy boxedTypeKind `thenNF_Tc` \ bndr_ty ->
- tcVarPat sig_fn name bndr_ty `thenTc` \ bndr_id ->
+ tc_pat_bndr name bndr_ty `thenTc` \ bndr_id ->
let
complete_it xve = tcAddSrcLoc locn $
tcMatchesFun xve name bndr_ty matches `thenTc` \ (matches', lie) ->
-- We don't check explicitly for this problem. Instead, we simply
-- type check the pattern with tcPat. If the pattern mentions any
-- fresh tyvars we simply get an out-of-scope type variable error
- tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
+ tcPat tc_pat_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
let
complete_it xve = tcAddSrcLoc locn $
tcAddErrCtxt (patMonoBindsCtxt bind) $
%* *
%************************************************************************
-
-@tcPragmaSigs@ munches up the "signatures" that arise through *user*
+@tcSpecSigs@ munches up the specialisation "signatures" that arise through *user*
pragmas. It is convenient for them to appear in the @[RenamedSig]@
part of a binding because then the same machinery can be used for
moving them into place as is done for type signatures.
-\begin{code}
-tcPragmaSigs :: [RenamedSig] -- The pragma signatures
- -> TcM s (Name -> IdInfo, -- Maps name to the appropriate IdInfo
- TcMonoBinds,
- LIE)
-
-tcPragmaSigs sigs
- = mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (maybe_info_modifiers, binds, lies) ->
- let
- prag_fn name = foldr ($) noIdInfo [f | Just (n,f) <- maybe_info_modifiers, n==name]
- in
- returnTc (prag_fn, andMonoBindList binds, plusLIEs lies)
-\end{code}
+They look like this:
-The interesting case is for SPECIALISE pragmas. There are two forms.
-Here's the first form:
\begin{verbatim}
f :: Ord a => [a] -> b -> b
{-# SPECIALIZE f :: [Int] -> b -> b #-}
Int, and will create a specialisation for @f@. After that, the
binding for @f*@ can be discarded.
-The second form is this:
-\begin{verbatim}
- f :: Ord a => [a] -> b -> b
- {-# SPECIALIZE f :: [Int] -> b -> b = g #-}
-\end{verbatim}
-
-Here @g@ is specified as a function that implements the specialised
-version of @f@. Suppose that g has type (a->b->b); that is, g's type
-is more general than that required. For this we generate
-\begin{verbatim}
- f@Int = /\b -> g Int b
- f* = f@Int
-\end{verbatim}
-
-Here @f@@Int@ is a SpecId, the specialised version of @f@. It inherits
-f's export status etc. @f*@ is a SpecPragmaId, as before, which just serves
-to prevent @f@@Int@ from being discarded prematurely. After specialisation,
-if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can
-discard the f* binding.
-
-Actually, there is really only point in giving a SPECIALISE pragma on exported things,
-and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is
-a bit of overkill.
+We used to have a form
+ {-# SPECIALISE f :: <type> = g #-}
+which promised that g implemented f at <type>, but we do that with
+a RULE now:
+ {-# SPECIALISE (f::<type) = g #-}
\begin{code}
-tcPragmaSig :: RenamedSig -> TcM s (Maybe (Name, IdInfo -> IdInfo), TcMonoBinds, LIE)
-tcPragmaSig (Sig _ _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
-tcPragmaSig (SpecInstSig _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
-
-tcPragmaSig (InlineSig name loc)
- = returnTc (Just (name, setInlinePragInfo IWantToBeINLINEd), EmptyMonoBinds, emptyLIE)
-
-tcPragmaSig (NoInlineSig name loc)
- = returnTc (Just (name, setInlinePragInfo IMustNotBeINLINEd), EmptyMonoBinds, emptyLIE)
-
-tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
+tcSpecSigs :: [RenamedSig] -> TcM s (TcMonoBinds, LIE)
+tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
= -- SPECIALISE f :: forall b. theta => tau = g
tcAddSrcLoc src_loc $
tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
-- the spec-pragma-id at the same time
tcExpr (HsVar name) sig_ty `thenTc` \ (spec_expr, spec_lie) ->
- case maybe_spec_name of
- Nothing -> -- Just specialise "f" by building a SpecPragmaId binding
- -- It is the thing that makes sure we don't prematurely
- -- dead-code-eliminate the binding we are really interested in.
- newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id ->
- returnTc (Nothing, VarMonoBind spec_id spec_expr, spec_lie)
-
- Just g_name -> -- Don't create a SpecPragmaId. Instead add some suitable IdIfo
-
- panic "Can't handle SPECIALISE with a '= g' part"
-
- {- Not yet. Because we're still in the TcType world we
- can't really add to the SpecEnv of the Id. Instead we have to
- record the information in a different sort of Sig, and add it to
- the IdInfo after zonking.
-
- For now we just leave out this case
-
- -- Get the type of f, and find out what types
- -- f has to be instantiated at to give the signature type
- tcLookupValue name `thenNF_Tc` \ f_id ->
- tcInstTcType (idType f_id) `thenNF_Tc` \ (f_tyvars, f_rho) ->
-
- let
- (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
- (f_theta, f_tau) = splitRhoTy f_rho
- sig_tyvar_set = mkVarSet sig_tyvars
- in
- unifyTauTy sig_tau f_tau `thenTc_`
-
- tcPolyExpr str (HsVar g_name) (mkSigmaTy sig_tyvars f_theta sig_tau) `thenTc` \ (_, _,
- -}
-
-tcPragmaSig other = pprTrace "tcPragmaSig: ignoring" (ppr other) $
- returnTc (Nothing, EmptyMonoBinds, emptyLIE)
+ -- Just specialise "f" by building a SpecPragmaId binding
+ -- It is the thing that makes sure we don't prematurely
+ -- dead-code-eliminate the binding we are really interested in.
+ newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id ->
+
+ -- Do the rest and combine
+ tcSpecSigs sigs `thenTc` \ (binds_rest, lie_rest) ->
+ returnTc (binds_rest `andMonoBinds` VarMonoBind spec_id spec_expr,
+ lie_rest `plusLIE` spec_lie)
+
+tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
+tcSpecSigs [] = returnTc (EmptyMonoBinds, emptyLIE)
\end{code}
ptext SLIT("because it is mutually recursive with Main.main") -- with commas inside SLIT strings.
mainTyCheckCtxt
- = hsep [ptext SLIT("When checking that"), ppr main_NAME, ptext SLIT("has the required type")]
+ = hsep [ptext SLIT("When checking that"), quotes (ppr main_NAME),
+ ptext SLIT("has the required type")]
-----------------------------------------------
unliftedBindErr flavour mbind
import DataCon ( dataConArgTys, isNullaryDataCon )
import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool )
-import Module ( Module )
+import Module ( ModuleName )
import Name ( isLocallyDefined, getSrcLoc,
Name, NamedThing(..),
OccName, nameOccName
%************************************************************************
\begin{code}
-tcDeriving :: Module -- name of module under scrutiny
+tcDeriving :: ModuleName -- name of module under scrutiny
-> Fixities -- for the deriving code (Show/Read.)
-> RnNameSupply -- for "renaming" bits of generated code
-> Bag InstInfo -- What we already know about instances
returnRn (dfun_names_w_method_binds, rn_extra_binds)
)
rn_one (cl_nm, tycon_nm, meth_binds)
- = newDFunName cl_nm tycon_nm
- Nothing mkGeneratedSrcLoc `thenRn` \ dfun_name ->
- rnMethodBinds meth_binds `thenRn` \ (rn_meth_binds, _) ->
+ = newDFunName (cl_nm, tycon_nm)
+ mkGeneratedSrcLoc `thenRn` \ dfun_name ->
+ rnMethodBinds meth_binds `thenRn` \ (rn_meth_binds, _) ->
returnRn (dfun_name, rn_meth_binds)
- really_new_inst_infos = map (gen_inst_info modname)
- (new_inst_infos `zip` dfun_names_w_method_binds)
+ really_new_inst_infos = zipWith gen_inst_info
+ new_inst_infos
+ dfun_names_w_method_binds
ddump_deriv = ddump_deriving really_new_inst_infos rn_extra_binds
in
ckey = classKey clas
-gen_inst_info :: Module -- Module name
- -> (InstInfo, (Name, RenamedMonoBinds)) -- the main stuff to work on
+gen_inst_info :: InstInfo
+ -> (Name, RenamedMonoBinds)
-> InstInfo -- the gen'd (filled-in) "instance decl"
-gen_inst_info modname
- (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ locn _, (dfun_name, meth_binds))
+gen_inst_info (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ locn _)
+ (dfun_name, meth_binds)
=
-- Generate the various instance-related Ids
InstInfo clas tyvars tys inst_decl_theta
import VarEnv
import VarSet
import Type ( Kind, superKind,
- tyVarsOfType, tyVarsOfTypes, mkTyVarTy, substTy,
- splitForAllTys, splitRhoTy, splitFunTys, substTopTy,
+ tyVarsOfType, tyVarsOfTypes, mkTyVarTy,
+ splitForAllTys, splitRhoTy, splitFunTys,
splitAlgTyConApp_maybe, getTyVar
)
+import Subst ( substTy )
import UsageSPUtils ( unannotTy )
import DataCon ( DataCon )
import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
import TcMonad
import BasicTypes ( Arity )
-import IdInfo ( noIdInfo )
+import IdInfo ( vanillaIdInfo )
import Name ( Name, OccName, nameOccName, getSrcLoc,
maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
NamedThing(..)
in
tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
let
- rho' = substTopTy tenv rho
+ rho' = substTy tenv rho
(theta', tau') = splitRhoTy rho'
in
returnNF_Tc (tyvars', theta', tau')
where
new_info = -- pprTrace "tcAdd" (ppr id) $
case explicitLookupValue unf_env (getName id) of
- Nothing -> noIdInfo
+ Nothing -> vanillaIdInfo
Just imported_id -> idInfo imported_id
-- ToDo: could check that types are the same
\end{code}
\section[TcExpr]{Typecheck an expression}
\begin{code}
-module TcExpr ( tcExpr, tcPolyExpr, tcId ) where
+module TcExpr ( tcApp, tcExpr, tcPolyExpr, tcId ) where
#include "HsVersions.h"
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
import TcHsSyn ( TcExpr, TcRecordBinds,
- mkHsTyApp, maybeBoxedPrimType
+ mkHsTyApp, mkHsLet, maybeBoxedPrimType
)
import TcMonad
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
- newMethod, newMethodWithGivenTy, newDicts, instToId )
+ newMethod, instOverloadedFun, newDicts, instToId )
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcInstId,
tcLookupValue, tcLookupClassByKey,
isTauTy, tyVarsOfType, tyVarsOfTypes,
isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
boxedTypeKind, mkArrowKind,
- substTopTheta, tidyOpenType
+ tidyOpenType
)
+import Subst ( mkTopTyVarSubst, substTheta )
import UsageSPUtils ( unannotTy )
-import VarEnv ( zipVarEnv )
import VarSet ( elemVarSet, mkVarSet )
import TyCon ( tyConDataCons )
import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
-- a couple of new names which seems worse.
generalised_arg = TyLam zonked_sig_tyvars $
DictLam dict_ids $
- HsLet (MonoBind inst_binds [] Recursive)
+ mkHsLet inst_binds $
arg'
in
returnTc ( generalised_arg, free_insts,
-- union the ones that could participate in the update.
let
(tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
- inst_env = zipVarEnv tyvars result_inst_tys
- theta' = substTopTheta inst_env theta
+ inst_env = mkTopTyVarSubst tyvars result_inst_tys
+ theta' = substTheta inst_env theta
in
newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
\begin{code}
-tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
- -> TcType -- Expected result type of application
- -> TcM s (TcExpr, [TcExpr], -- Translated fun and args
+tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
+ -> TcType -- Expected result type of application
+ -> TcM s (TcExpr, [TcExpr], -- Translated fun and args
LIE)
tcApp fun args res_ty
tcLookupValueMaybe name `thenNF_Tc` \ maybe_local ->
case maybe_local of
- Just tc_id -> instantiate_it tc_id (unannotTy (idType tc_id))
+ Just tc_id -> instantiate_it (OccurrenceOf tc_id) (HsVar tc_id) (unannotTy (idType tc_id))
Nothing -> tcLookupValue name `thenNF_Tc` \ id ->
tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) ->
- instantiate_it2 id tyvars theta tau
+ instantiate_it2 (OccurrenceOf id) (HsVar id) tyvars theta tau
where
-- The instantiate_it loop runs round instantiating the Id.
-- f:: forall a. Eq a => forall b. Baz b => tau
-- We want to instantiate this to
-- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
- instantiate_it tc_id_occ ty
+ instantiate_it orig fun ty
= tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) ->
- instantiate_it2 tc_id_occ tyvars theta tau
+ instantiate_it2 orig fun tyvars theta tau
- instantiate_it2 tc_id_occ tyvars theta tau
+ instantiate_it2 orig fun tyvars theta tau
= if null theta then -- Is it overloaded?
- returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
+ returnNF_Tc (mkHsTyApp fun arg_tys, emptyLIE, tau)
else
-- Yes, it's overloaded
- newMethodWithGivenTy (OccurrenceOf tc_id_occ)
- tc_id_occ arg_tys theta tau `thenNF_Tc` \ inst ->
- instantiate_it (instToId inst) tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
- returnNF_Tc (expr, unitLIE inst `plusLIE` lie2, final_tau)
+ instOverloadedFun orig fun arg_tys theta tau `thenNF_Tc` \ (fun', lie1) ->
+ instantiate_it orig fun' tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
+ returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
where
- arg_tys = mkTyVarTys tyvars
+ arg_tys = mkTyVarTys tyvars
\end{code}
%************************************************************************
newTyVarTy (mkArrowKind boxedTypeKind boxedTypeKind) `thenNF_Tc` \ m ->
newTyVarTy boxedTypeKind `thenNF_Tc` \ elt_ty ->
unifyTauTy res_ty (mkAppTy m elt_ty) `thenTc_`
+
-- If it's a comprehension we're dealing with,
-- force it to be a list comprehension.
-- (as of Haskell 98, monad comprehensions are no more.)
import CoreSyn
import ErrUtils ( Message )
-import Id ( Id, idName, mkUserId )
+import Id ( Id, idName, mkVanillaId )
import Name ( nameOccName )
import Type ( splitFunTys
, splitTyConApp_maybe
case splitFunTys t_ty of
(arg_tys, res_ty) ->
checkForeignExport True t_ty arg_tys res_ty `thenTc_`
- let i = (mkUserId nm sig_ty) in
+ let i = (mkVanillaId nm sig_ty) in
returnTc (i, (ForeignDecl i FoExport undefined Dynamic cconv src_loc))
tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
(_, t_ty) = splitForAllTys sig_ty
in
check (isAddrTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_`
- let i = (mkUserId nm sig_ty) in
+ let i = (mkVanillaId nm sig_ty) in
returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc))
tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
case splitFunTys t_ty of
(arg_tys, res_ty) ->
checkForeignImport (isDynamic ext_nm) ty arg_tys res_ty `thenTc_`
- let i = (mkUserId nm ty) in
+ let i = (mkVanillaId nm ty) in
returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
tcFExport :: RenamedForeignDecl -> TcM s (LIE, TcMonoBinds, TcForeignExportDecl)
TcHsModule, TcCoreExpr, TcDictBinds,
TcForeignExportDecl,
- TypecheckedHsBinds,
+ TypecheckedHsBinds, TypecheckedRuleDecl,
TypecheckedMonoBinds, TypecheckedPat,
TypecheckedHsExpr, TypecheckedArithSeqInfo,
TypecheckedStmt, TypecheckedForeignDecl,
TypecheckedRecordBinds, TypecheckedDictBinds,
mkHsTyApp, mkHsDictApp,
- mkHsTyLam, mkHsDictLam,
+ mkHsTyLam, mkHsDictLam, mkHsLet,
-- re-exported from TcEnv
TcId, tcInstId,
maybeBoxedPrimType,
zonkTopBinds, zonkId, zonkIdOcc,
- zonkForeignExports
+ zonkForeignExports, zonkRules
) where
#include "HsVersions.h"
import VarEnv ( TyVarEnv, emptyVarEnv, extendVarEnvList )
import VarSet ( isEmptyVarSet )
import CoreSyn ( Expr )
+import BasicTypes ( RecFlag(..) )
import Bag
import UniqFM
import Outputable
type TcCoreExpr = Expr TcId
type TcForeignExportDecl = ForeignDecl TcId
+type TcRuleDecl = RuleDecl TcId TcPat
type TypecheckedPat = OutPat Id
type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
type TypecheckedHsModule = HsModule Id TypecheckedPat
type TypecheckedForeignDecl = ForeignDecl Id
+type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
\end{code}
\begin{code}
mkHsDictLam [] expr = expr
mkHsDictLam dicts expr = DictLam dicts expr
+
+mkHsLet EmptyMonoBinds expr = expr
+mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
\end{code}
%************************************************************************
returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
-zonkMonoBinds (AbsBinds tyvars dicts exports val_bind)
+zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
= mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
-- No need to extend tyvar env: the effects are
-- propagated through binding the tyvars themselves
let
new_globals = listToBag [global | (_, global, local) <- new_exports]
in
- returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind,
+ returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
new_globals)
where
zonkExport (tyvars, global, local)
zonkIdOcc i `thenNF_Tc` \ i' ->
returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
\end{code}
+
+\begin{code}
+zonkRules :: [TcRuleDecl] -> NF_TcM s [TypecheckedRuleDecl]
+zonkRules rs = mapNF_Tc zonkRule rs
+
+zonkRule (RuleDecl name tyvars vars lhs rhs loc)
+ = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
+ mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs ->
+ tcExtendGlobalValEnv new_bndrs $
+ zonkExpr lhs `thenNF_Tc` \ new_lhs ->
+ zonkExpr rhs `thenNF_Tc` \ new_rhs ->
+ returnNF_Tc (RuleDecl name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
+ -- I hate this map RuleBndr stuff
+
+zonkRule (IfaceRuleDecl fun rule loc)
+ = returnNF_Tc (IfaceRuleDecl fun rule loc)
+\end{code}
\section[TcIfaceSig]{Type checking of type signatures in interface files}
\begin{code}
-module TcIfaceSig ( tcInterfaceSigs ) where
+module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
#include "HsVersions.h"
import RnHsSyn ( RenamedHsDecl )
import HsCore
-import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) )
import CallConv ( cCallConv )
import Const ( Con(..), Literal(..) )
import CoreSyn
import WwLib ( mkWrapper )
import PrimOp ( PrimOp(..) )
-import Id ( Id, mkImportedId, mkUserId,
+import Id ( Id, mkId, mkVanillaId,
isPrimitiveId_maybe, isDataConId_maybe
)
import IdInfo
import DataCon ( dataConSig, dataConArgTys )
-import SpecEnv ( addToSpecEnv )
import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp )
import Var ( IdOrTyVar, mkTyVar, tyVarKind )
import VarEnv
import Name ( Name, NamedThing(..) )
import Unique ( rationalTyConKey )
import TysWiredIn ( integerTy, stringTy )
+import Demand ( wwLazy )
import ErrUtils ( pprBagOfErrors )
import Maybes ( maybeToBool, MaybeErr(..) )
import Outputable
= tcAddSrcLoc src_loc (
tcAddErrCtxt (ifaceSigCtxt name) (
tcHsType ty `thenTc` \ sigma_ty ->
- tcIdInfo unf_env name sigma_ty noIdInfo id_infos `thenTc` \ id_info ->
- returnTc (mkImportedId name sigma_ty id_info)
+ tcIdInfo unf_env name sigma_ty vanillaIdInfo id_infos `thenTc` \ id_info ->
+ returnTc (mkId name sigma_ty id_info)
)) `thenTc` \ sig_id ->
tcInterfaceSigs unf_env rest `thenTc` \ sig_ids ->
returnTc (sig_id : sig_ids)
\begin{code}
tcIdInfo unf_env name ty info info_ins
- = foldlTc tcPrag noIdInfo info_ins
+ = foldlTc tcPrag vanillaIdInfo info_ins
where
- tcPrag info (HsArity arity) = returnTc (arity `setArityInfo` info)
- tcPrag info (HsUpdate upd) = returnTc (upd `setUpdateInfo` info)
- tcPrag info (HsNoCafRefs) = returnTc (NoCafRefs `setCafInfo` info)
- tcPrag info (HsCprInfo cpr_info) = returnTc (cpr_info `setCprInfo` info)
+ tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity)
+ tcPrag info (HsUpdate upd) = returnTc (info `setUpdateInfo` upd)
+ tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs)
+ tcPrag info (HsCprInfo cpr_info) = returnTc (info `setCprInfo` cpr_info)
tcPrag info (HsUnfold inline_prag maybe_expr)
= (case maybe_expr of
unfold_info = case maybe_expr' of
Nothing -> NoUnfolding
Just expr' -> mkUnfolding expr'
- info1 = unfold_info `setUnfoldingInfo` info
-
- info2 = inline_prag `setInlinePragInfo` info1
+ info1 = info `setUnfoldingInfo` unfold_info
+ info2 = info1 `setInlinePragInfo` inline_prag
in
returnTc info2
tcPrag info (HsStrictness (HsStrictnessInfo (demands,bot_result)))
- = returnTc (StrictnessInfo demands bot_result `setStrictnessInfo` info)
-
- tcPrag info (HsWorker nm cons)
- = tcWorkerInfo unf_env ty info nm cons
-
- tcPrag info (HsSpecialise tyvars tys rhs)
- = tcExtendTyVarScope tyvars $ \ tyvars' ->
- mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (kinds, tys') ->
- -- Assume that the kinds match the kinds of the
- -- type variables of the function; this is, after all, an
- -- interface file generated by the compiler!
+ = returnTc (info `setStrictnessInfo` StrictnessInfo demands bot_result)
- tcPragExpr unf_env name tyvars' rhs `thenNF_Tc` \ maybe_rhs' ->
- let
- -- If spec_env isn't looked at, none of this
- -- actually takes place
- spec_env = specInfo info
- spec_env' = case maybe_rhs' of
- Nothing -> spec_env
- Just rhs' -> case addToSpecEnv True {- overlap ok -} spec_env tyvars' tys' rhs' of
- Succeeded spec_env' -> spec_env'
- Failed err -> pprTrace "tcIdInfo: bad specialisation"
- (ppr name <+> ppr err) $
- spec_env
- in
- returnTc (spec_env' `setSpecInfo` info)
+ tcPrag info (HsWorker nm)
+ = tcWorkerInfo unf_env ty info nm
\end{code}
\begin{code}
-tcWorkerInfo unf_env ty info nm cons
- = tcWorker unf_env (Just (nm,cons)) `thenNF_Tc` \ maybe_worker_id ->
- -- We are relying here on cpr and strictness info always appearing
- -- before strictness info, fingers crossed ....
+tcWorkerInfo unf_env ty info worker_name
+ | arity == 0
+ = pprPanic "Worker with no arity info" (ppr worker_name)
+
+ | otherwise
+ = uniqSMToTcM (mkWrapper ty arity demands cpr_info) `thenNF_Tc` \ wrap_fn ->
let
- demands = case strictnessInfo info of
- StrictnessInfo d _ -> d
- _ -> []
- cpr_info = cprInfo info
- in
- uniqSMToTcM (mkWrapper ty demands cpr_info) `thenNF_Tc` \ wrap_fn ->
- let
- -- Watch out! We can't pull on maybe_worker_id too eagerly!
- info' = case maybe_worker_id of
- Just worker_id -> setUnfoldingInfo (mkUnfolding (wrap_fn worker_id)) $
- setWorkerInfo (Just worker_id) $
- setInlinePragInfo IWantToBeINLINEd info
-
- Nothing -> info
+ -- Watch out! We can't pull on unf_env too eagerly!
+ info' = case explicitLookupValue unf_env worker_name of
+ Just worker_id -> info `setUnfoldingInfo` mkUnfolding (wrap_fn worker_id)
+ `setWorkerInfo` Just worker_id
- has_worker = maybeToBool maybe_worker_id
+ Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
in
returnTc info'
-\end{code}
-
-\begin{code}
-tcWorker unf_env Nothing = returnNF_Tc Nothing
-
-tcWorker unf_env (Just (worker_name,_))
- = returnNF_Tc (trace_maybe maybe_worker_id)
where
- maybe_worker_id = explicitLookupValue unf_env worker_name
-
- -- The trace is so we can see what's getting dropped
- trace_maybe Nothing = pprTrace "tcWorker failed:" (ppr worker_name) Nothing
- trace_maybe (Just x) = Just x
+ -- We are relying here on arity, cpr and strictness info always appearing
+ -- before worker info, fingers crossed ....
+ arity = arityLowerBound (arityInfo info)
+ cpr_info = cprInfo info
+ demands = case strictnessInfo info of
+ StrictnessInfo d _ -> d
+ _ -> repeat wwLazy -- Noncommittal
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
an unfolding that isn't going to be looked at.
\begin{code}
-tcPragExpr :: ValueEnv -> Name -> [IdOrTyVar] -> UfExpr Name -> NF_TcM s (Maybe CoreExpr)
-tcPragExpr unf_env name in_scope_vars core_expr
- = forkNF_Tc (
- recoverNF_Tc no_unfolding (
- tcSetValueEnv unf_env $
- tcCoreExpr core_expr `thenTc` \ core_expr' ->
+tcPragExpr unf_env name in_scope_vars expr
+ = tcDelay unf_env doc $
+ tcCoreExpr expr `thenTc` \ core_expr' ->
-- Check for type consistency in the unfolding
- tcGetSrcLoc `thenNF_Tc` \ src_loc ->
- returnTc (lintUnfolding src_loc in_scope_vars core_expr')
+ tcGetSrcLoc `thenNF_Tc` \ src_loc ->
+ case lintUnfolding src_loc in_scope_vars core_expr' of
+ Nothing -> returnTc core_expr'
+ Just fail_msg -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
+ where
+ doc = text "unfolding of" <+> ppr name
+
+tcDelay :: ValueEnv -> SDoc -> TcM s a -> NF_TcM s (Maybe a)
+tcDelay unf_env doc thing_inside
+ = forkNF_Tc (
+ recoverNF_Tc bad_value (
+ tcSetValueEnv unf_env thing_inside `thenTc` \ r ->
+ returnTc (Just r)
))
where
-- The trace tells what wasn't available, for the benefit of
-- compiler hackers who want to improve it!
- no_unfolding = getErrsTc `thenNF_Tc` \ (warns,errs) ->
- returnNF_Tc (pprTrace "tcUnfolding failed with:"
- (hang (ppr name) 4 (pprBagOfErrors errs))
+ bad_value = getErrsTc `thenNF_Tc` \ (warns,errs) ->
+ returnNF_Tc (pprTrace "Failed:"
+ (hang doc 4 (pprBagOfErrors errs))
Nothing)
\end{code}
= tcCoreExpr scrut `thenTc` \ scrut' ->
let
scrut_ty = coreExprType scrut'
- case_bndr' = mkUserId case_bndr scrut_ty
+ case_bndr' = mkVanillaId case_bndr scrut_ty
in
tcExtendGlobalValEnv [case_bndr'] $
mapTc (tcCoreAlt scrut_ty) alts `thenTc` \ alts' ->
UfCoerce to_ty -> tcHsType to_ty `thenTc` \ to_ty' ->
returnTc (Note (Coerce to_ty' (coreExprType expr')) expr')
UfInlineCall -> returnTc (Note InlineCall expr')
- UfSCC cc -> returnTc (Note (SCC cc) expr')
+ UfInlineMe -> returnTc (Note InlineMe expr')
+ UfSCC cc -> returnTc (Note (SCC cc) expr')
tcCoreNote (UfSCC cc) = returnTc (SCC cc)
tcCoreNote UfInlineCall = returnTc InlineCall
tcCoreLamBndr (UfValBinder name ty) thing_inside
= tcHsType ty `thenTc` \ ty' ->
let
- id = mkUserId name ty'
+ id = mkVanillaId name ty'
in
tcExtendGlobalValEnv [id] $
thing_inside id
in
tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
+tcCoreLamBndrs [] thing_inside = thing_inside []
+tcCoreLamBndrs (b:bs) thing_inside
+ = tcCoreLamBndr b $ \ b' ->
+ tcCoreLamBndrs bs $ \ bs' ->
+ thing_inside (b':bs')
+
tcCoreValBndr (UfValBinder name ty) thing_inside
= tcHsType ty `thenTc` \ ty' ->
let
- id = mkUserId name ty'
+ id = mkVanillaId name ty'
in
tcExtendGlobalValEnv [id] $
thing_inside id
tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders
= mapTc tcHsType tys `thenTc` \ tys' ->
let
- ids = zipWithEqual "tcCoreValBndr" mkUserId names tys'
+ ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys'
in
tcExtendGlobalValEnv ids $
thing_inside ids
ppr arg_tys)
| otherwise
#endif
- = zipWithEqual "tcCoreAlts" mkUserId id_names arg_tys
+ = zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys
in
ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
tcExtendTyVarEnv ex_tyvars' $
import Inst ( InstanceMapper )
import Bag ( bagToList, Bag )
-import Class ( ClassInstEnv, Class )
+import Class ( Class )
import Var ( TyVar, Id )
-import SpecEnv ( emptySpecEnv, addToSpecEnv )
+import InstEnv ( InstEnv, emptyInstEnv, addToInstEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef )
import Name ( getSrcLoc )
import SrcLoc ( SrcLoc )
in
mapNF_Tc buildInstanceEnv info_by_class `thenNF_Tc` \ inst_env_entries ->
let
- class_lookup_fn = mkLookupFunDef (==) inst_env_entries emptySpecEnv
+ class_lookup_fn = mkLookupFunDef (==) inst_env_entries emptyInstEnv
in
returnNF_Tc class_lookup_fn
\end{code}
\begin{code}
buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class
- -> NF_TcM s (Class, ClassInstEnv)
+ -> NF_TcM s (Class, InstEnv)
buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _) : _)
= foldrNF_Tc addClassInstance
- emptySpecEnv
+ emptyInstEnv
inst_infos `thenNF_Tc` \ class_inst_env ->
returnNF_Tc (clas, class_inst_env)
\end{code}
\begin{code}
addClassInstance
:: InstInfo
- -> ClassInstEnv
- -> NF_TcM s ClassInstEnv
+ -> InstEnv
+ -> NF_TcM s InstEnv
addClassInstance
(InstInfo clas inst_tyvars inst_tys _
dfun_id _ src_loc _)
class_inst_env
= -- Add the instance to the class's instance environment
- case addToSpecEnv opt_AllowOverlappingInstances
+ case addToInstEnv opt_AllowOverlappingInstances
class_inst_env inst_tyvars inst_tys dfun_id of
Failed (ty', dfun_id') -> addErrTc (dupInstErr clas (inst_tys, src_loc)
(ty', getSrcLoc dfun_id'))
import TcHsSyn ( TcMatch, TcGRHSs, TcStmt )
import TcMonad
-import TcMonoType ( checkSigTyVars, tcHsTyVar, tcHsType, noSigs, sigPatCtxt )
+import TcMonoType ( checkSigTyVars, tcHsTyVar, tcHsType, sigPatCtxt )
import Inst ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
import TcEnv ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv )
-import TcPat ( tcPat, polyPatSig )
+import TcPat ( tcPat, tcPatBndr_NoSigs, polyPatSig )
import TcType ( TcType, newTyVarTy, newTyVarTy_OpenKind )
import TcBinds ( tcBindsAndThen )
import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
= returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
tcMatchPats (pat:pats) expected_ty
- = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
- tcPat noSigs pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
- tcMatchPats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
+ = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
+ tcPat tcPatBndr_NoSigs pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
+ tcMatchPats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
returnTc ( rhs_ty,
pat':pats',
lie_req `plusLIE` lie_reqs,
= tcAddSrcLoc src_loc (
tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty ->
- tcPat noSigs pat pat_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
+ tcPat tcPatBndr_NoSigs pat pat_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
returnTc (pat', exp',
pat_lie `plusLIE` exp_lie,
\begin{code}
module TcModule (
typecheckModule,
- TcResults
+ TcResults(..)
) where
#include "HsVersions.h"
import CmdLineOpts ( opt_D_dump_tc )
import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) )
import RnHsSyn ( RenamedHsModule )
-import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds, zonkTopBinds,
- TypecheckedForeignDecl, zonkForeignExports
+import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds,
+ TypecheckedForeignDecl, TypecheckedRuleDecl,
+ zonkTopBinds, zonkForeignExports, zonkRules
)
import TcMonad
ValueEnv, TcTyThing(..)
)
import TcExpr ( tcId )
+import TcRules ( tcRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
pprBagOfErrors, dumpIfSet
)
import Id ( Id, idType )
-import Module ( pprModule )
+import Module ( pprModuleName )
import Name ( Name, nameUnique, isLocallyDefined, NamedThing(..) )
import TyCon ( TyCon, tyConKind )
import DataCon ( dataConId )
import Type ( mkTyConApp, mkForAllTy,
boxedTypeKind, getTyVar, Type )
import TysWiredIn ( unitTy )
-import PrelMods ( mAIN )
+import PrelMods ( mAIN_Name )
import PrelInfo ( main_NAME, thinAirIdNames, setThinAirIds )
import TcUnify ( unifyTauTy )
import Unique ( Unique )
\begin{code}
-- Convenient type synonyms first:
-type TcResults
- = (TypecheckedMonoBinds,
- [TyCon], [Class],
- Bag InstInfo, -- Instance declaration information
- [TypecheckedForeignDecl], -- foreign import & exports.
- ValueEnv,
- [Id] -- The thin-air Ids
- )
+data TcResults
+ = TcResults {
+ tc_binds :: TypecheckedMonoBinds,
+ tc_tycons :: [TyCon],
+ tc_classes :: [Class],
+ tc_insts :: Bag InstInfo, -- Instance declaration information
+ tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports.
+ tc_rules :: [TypecheckedRuleDecl], -- Transformation rules
+ tc_env :: ValueEnv,
+ tc_thinair :: [Id] -- The thin-air Ids
+ }
---------------
typecheckModule
-- write the thin-air Id map
(case maybe_result of
- Just (_, _, _, _, _, _, thin_air_ids) -> setThinAirIds thin_air_ids
- Nothing -> return ()
+ Just results -> setThinAirIds (tc_thinair results)
+ Nothing -> return ()
) >>
dumpIfSet opt_D_dump_tc "Typechecked"
(case maybe_result of
- Just (binds, _, _, _, _, _, _) -> ppr binds
- Nothing -> text "Typecheck failed") >>
+ Just results -> ppr (tc_binds results)
+ $$
+ pp_rules (tc_rules results)
+ Nothing -> text "Typecheck failed") >>
return (if isEmptyBag errs then
maybe_result
else
Nothing)
+pp_rules [] = empty
+pp_rules rs = vcat [ptext SLIT("{-# RULES"),
+ nest 4 (vcat (map ppr rs)),
+ ptext SLIT("#-}")]
+
print_errs errs
| isEmptyBag errs = return ()
| otherwise = printErrs (pprBagOfErrors errs)
-- to compile the bindings themselves.
tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
+ tcRules decls `thenNF_Tc` \ (lie_rules, rules) ->
-- Deal with constant or ambiguous InstIds. How could
lie_alldecls = lie_valdecls `plusLIE`
lie_instdecls `plusLIE`
lie_clasdecls `plusLIE`
- lie_fodecls
+ lie_fodecls `plusLIE`
+ lie_rules
in
tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
-- Check that Main defines main
- (if mod_name == mAIN then
+ (if mod_name == mAIN_Name then
tcLookupValueMaybe main_NAME `thenNF_Tc` \ maybe_main ->
checkTc (maybeToBool maybe_main) noMainErr
else
zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) ->
tcSetValueEnv really_final_env $
zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
+ zonkRules rules `thenNF_Tc` \ rules' ->
let
thin_air_ids = map (explicitLookupValueByKey really_final_env . nameUnique) thinAirIdNames
-- Hence using really_final_env
in
returnTc (really_final_env,
- (all_binds', local_tycons, local_classes, inst_info,
- (foi_decls ++ foe_decls'),
- really_final_env,
- thin_air_ids))
+ (TcResults { tc_binds = all_binds',
+ tc_tycons = local_tycons,
+ tc_classes = local_classes,
+ tc_insts = inst_info,
+ tc_fords = foi_decls ++ foe_decls',
+ tc_rules = rules',
+ tc_env = really_final_env,
+ tc_thinair = thin_air_ids
+ }))
)
-- End of outer fix loop
\begin{code}
noMainErr
- = hsep [ptext SLIT("Module"), quotes (pprModule mAIN),
+ = hsep [ptext SLIT("Module"), quotes (pprModuleName mAIN_Name),
ptext SLIT("must include a definition for"), quotes (ppr main_NAME)]
\end{code}
\section[TcPat]{Typechecking patterns}
\begin{code}
-module TcPat ( tcPat, tcVarPat, badFieldCon, polyPatSig ) where
+module TcPat ( tcPat, tcPatBndr_NoSigs, badFieldCon, polyPatSig ) where
#include "HsVersions.h"
import TcMonad
import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
emptyLIE, plusLIE, LIE,
- newMethod, newMethodWithGivenTy, newOverloadedLit,
+ newMethod, newOverloadedLit,
newDicts, instToIdBndr
)
import Name ( Name, getOccName, getSrcLoc )
import Bag ( Bag )
import CmdLineOpts ( opt_IrrefutableTuples )
import DataCon ( DataCon, dataConSig, dataConFieldLabels, dataConSourceArity )
-import Id ( Id, mkUserId, idType, isDataConId_maybe )
-import Type ( Type, isTauTy, substTopTy, substTopTheta, mkTyConApp )
+import Id ( Id, idType, isDataConId_maybe )
+import Type ( Type, isTauTy, mkTyConApp )
+import Subst ( substTy, substTheta )
import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, addrPrimTy
)
%************************************************************************
\begin{code}
-tcVarPat :: (Name -> Maybe TcId) -- Info about signatures; gives the *monomorphic*
- -- Id for variables with a type signature
- -> Name
-
- -> TcType -- Expected type, derived from the context
- -- In the case of a function with a rank-2 signature,
- -- this type might be a forall type.
- -- INVARIANT: if it is, the foralls will always be visible,
- -- not hidden inside a mutable type variable
-
- -> TcM s TcId -- The monomorphic Id; this is put in the pattern itself
-
-tcVarPat sig_fn binder_name pat_ty
- = case sig_fn binder_name of
- Nothing -> -- Need to make a new, monomorphic, Id
- -- The binder_name is already being used for the polymorphic Id
- newLocalId (getOccName binder_name) pat_ty loc `thenNF_Tc` \ bndr_id ->
- returnTc bndr_id
-
- Just bndr_id -> tcAddSrcLoc loc $
- unifyTauTy (idType bndr_id) pat_ty `thenTc_`
- returnTc bndr_id
+-- This is the right function to pass to tcPat when there are no signatures
+tcPatBndr_NoSigs binder_name pat_ty
+ = -- Need to make a new, monomorphic, Id
+ -- The binder_name is already being used for the polymorphic Id
+ newLocalId (getOccName binder_name) pat_ty loc `thenNF_Tc` \ bndr_id ->
+ returnTc bndr_id
where
loc = getSrcLoc binder_name
\end{code}
%************************************************************************
\begin{code}
-tcPat :: (Name -> Maybe TcId) -- Info about signatures; gives the *monomorphic*
- -- Id for variables with a type signature
+tcPat :: (Name -> TcType -> TcM s TcId) -- How to construct a suitable (monomorphic)
+ -- Id for variables found in the pattern
+ -- The TcType is the expected type, see note below
-> RenamedPat
- -> TcType -- Expected type; see invariant in tcVarPat
+
+ -> TcType -- Expected type derived from the context
+ -- In the case of a function with a rank-2 signature,
+ -- this type might be a forall type.
+ -- INVARIANT: if it is, the foralls will always be visible,
+ -- not hidden inside a mutable type variable
+
-> TcM s (TcPat,
LIE, -- Required by n+k and literal pats
Bag TcTyVar, -- TyVars bound by the pattern
%************************************************************************
\begin{code}
-tcPat sig_fn (VarPatIn name) pat_ty
- = tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
+tcPat tc_bndr (VarPatIn name) pat_ty
+ = tc_bndr name pat_ty `thenTc` \ bndr_id ->
returnTc (VarPat bndr_id, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
-tcPat sig_fn (LazyPatIn pat) pat_ty
- = tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
+tcPat tc_bndr (LazyPatIn pat) pat_ty
+ = tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
returnTc (LazyPat pat', lie_req, tvs, ids, lie_avail)
-tcPat sig_fn pat_in@(AsPatIn name pat) pat_ty
- = tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
- tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
+tcPat tc_bndr pat_in@(AsPatIn name pat) pat_ty
+ = tc_bndr name pat_ty `thenTc` \ bndr_id ->
+ tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
tcAddErrCtxt (patCtxt pat_in) $
returnTc (AsPat bndr_id pat', lie_req,
tvs, (name, bndr_id) `consBag` ids, lie_avail)
-tcPat sig_fn WildPatIn pat_ty
+tcPat tc_bndr WildPatIn pat_ty
= returnTc (WildPat pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
-tcPat sig_fn (NegPatIn pat) pat_ty
- = tcPat sig_fn (negate_lit pat) pat_ty
+tcPat tc_bndr (NegPatIn pat) pat_ty
+ = tcPat tc_bndr (negate_lit pat) pat_ty
where
negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i))
negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
negate_lit _ = panic "TcPat:negate_pat"
-tcPat sig_fn (ParPatIn parend_pat) pat_ty
- = tcPat sig_fn parend_pat pat_ty
+tcPat tc_bndr (ParPatIn parend_pat) pat_ty
+ = tcPat tc_bndr parend_pat pat_ty
-tcPat sig_fn (SigPatIn pat sig) pat_ty
+tcPat tc_bndr (SigPatIn pat sig) pat_ty
= tcHsType sig `thenTc` \ sig_ty ->
-- Check that the signature isn't a polymorphic one, which
checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_`
unifyTauTy pat_ty sig_ty `thenTc_`
- tcPat sig_fn pat sig_ty
+ tcPat tc_bndr pat sig_ty
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcPat sig_fn pat_in@(ListPatIn pats) pat_ty
+tcPat tc_bndr pat_in@(ListPatIn pats) pat_ty
= tcAddErrCtxt (patCtxt pat_in) $
unifyListTy pat_ty `thenTc` \ elem_ty ->
- tcPats sig_fn pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
+ tcPats tc_bndr pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail)
-tcPat sig_fn pat_in@(TuplePatIn pats boxed) pat_ty
+tcPat tc_bndr pat_in@(TuplePatIn pats boxed) pat_ty
= tcAddErrCtxt (patCtxt pat_in) $
(if boxed
then unifyTupleTy arity pat_ty
else unifyUnboxedTupleTy arity pat_ty) `thenTc` \ arg_tys ->
- tcPats sig_fn pats arg_tys `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
+ tcPats tc_bndr pats arg_tys `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
-- possibly do the "make all tuple-pats irrefutable" test:
let
%************************************************************************
\begin{code}
-tcPat sig_fn pat@(ConPatIn name arg_pats) pat_ty
- = tcConPat sig_fn pat name arg_pats pat_ty
+tcPat tc_bndr pat@(ConPatIn name arg_pats) pat_ty
+ = tcConPat tc_bndr pat name arg_pats pat_ty
-tcPat sig_fn pat@(ConOpPatIn pat1 op _ pat2) pat_ty
- = tcConPat sig_fn pat op [pat1, pat2] pat_ty
+tcPat tc_bndr pat@(ConOpPatIn pat1 op _ pat2) pat_ty
+ = tcConPat tc_bndr pat op [pat1, pat2] pat_ty
\end{code}
%************************************************************************
\begin{code}
-tcPat sig_fn pat@(RecPatIn name rpats) pat_ty
+tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty
= tcAddErrCtxt (patCtxt pat) $
-- Check the constructor itself
tc_fields field_tys rpats `thenTc` \ (rpats', lie_req1, tvs1, ids1, lie_avail1) ->
tcLookupValue field_label `thenNF_Tc` \ sel_id ->
- tcPat sig_fn rhs_pat rhs_ty `thenTc` \ (rhs_pat', lie_req2, tvs2, ids2, lie_avail2) ->
+ tcPat tc_bndr rhs_pat rhs_ty `thenTc` \ (rhs_pat', lie_req2, tvs2, ids2, lie_avail2) ->
returnTc ((sel_id, rhs_pat', pun_flag) : rpats',
lie_req1 `plusLIE` lie_req2,
%************************************************************************
\begin{code}
-tcPat sig_fn (LitPatIn lit@(HsChar _)) pat_ty = tcSimpleLitPat lit charTy pat_ty
-tcPat sig_fn (LitPatIn lit@(HsIntPrim _)) pat_ty = tcSimpleLitPat lit intPrimTy pat_ty
-tcPat sig_fn (LitPatIn lit@(HsCharPrim _)) pat_ty = tcSimpleLitPat lit charPrimTy pat_ty
-tcPat sig_fn (LitPatIn lit@(HsStringPrim _)) pat_ty = tcSimpleLitPat lit addrPrimTy pat_ty
-tcPat sig_fn (LitPatIn lit@(HsFloatPrim _)) pat_ty = tcSimpleLitPat lit floatPrimTy pat_ty
-tcPat sig_fn (LitPatIn lit@(HsDoublePrim _)) pat_ty = tcSimpleLitPat lit doublePrimTy pat_ty
-
-tcPat sig_fn (LitPatIn lit@(HsLitLit s)) pat_ty = tcSimpleLitPat lit intTy pat_ty
+tcPat tc_bndr (LitPatIn lit@(HsChar _)) pat_ty = tcSimpleLitPat lit charTy pat_ty
+tcPat tc_bndr (LitPatIn lit@(HsIntPrim _)) pat_ty = tcSimpleLitPat lit intPrimTy pat_ty
+tcPat tc_bndr (LitPatIn lit@(HsCharPrim _)) pat_ty = tcSimpleLitPat lit charPrimTy pat_ty
+tcPat tc_bndr (LitPatIn lit@(HsStringPrim _)) pat_ty = tcSimpleLitPat lit addrPrimTy pat_ty
+tcPat tc_bndr (LitPatIn lit@(HsFloatPrim _)) pat_ty = tcSimpleLitPat lit floatPrimTy pat_ty
+tcPat tc_bndr (LitPatIn lit@(HsDoublePrim _)) pat_ty = tcSimpleLitPat lit doublePrimTy pat_ty
+
+tcPat tc_bndr (LitPatIn lit@(HsLitLit s)) pat_ty = tcSimpleLitPat lit intTy pat_ty
-- This one looks weird!
\end{code}
%************************************************************************
\begin{code}
-tcPat sig_fn pat@(LitPatIn lit@(HsString str)) pat_ty
+tcPat tc_bndr pat@(LitPatIn lit@(HsString str)) pat_ty
= unifyTauTy pat_ty stringTy `thenTc_`
tcLookupValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
newMethod (PatOrigin pat) sel_id [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
returnTc (NPat lit stringTy comp_op, lie, emptyBag, emptyBag, emptyLIE)
-tcPat sig_fn pat@(LitPatIn lit@(HsInt i)) pat_ty
+tcPat tc_bndr pat@(LitPatIn lit@(HsInt i)) pat_ty
= tcOverloadedLitPat pat lit (OverloadedIntegral i) pat_ty
-tcPat sig_fn pat@(LitPatIn lit@(HsFrac f)) pat_ty
+tcPat tc_bndr pat@(LitPatIn lit@(HsFrac f)) pat_ty
= tcOverloadedLitPat pat lit (OverloadedFractional f) pat_ty
-tcPat sig_fn pat@(NPlusKPatIn name lit@(HsInt i)) pat_ty
- = tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
+tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsInt i)) pat_ty
+ = tc_bndr name pat_ty `thenTc` \ bndr_id ->
tcLookupValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id ->
tcLookupValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id ->
where
origin = PatOrigin pat
-tcPat sig_fn (NPlusKPatIn pat other) pat_ty
+tcPat tc_bndr (NPlusKPatIn pat other) pat_ty
= panic "TcPat:NPlusKPat: not an HsInt literal"
\end{code}
Helper functions
\begin{code}
-tcPats :: (Name -> Maybe TcId) -- Info about signatures
- -> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded
+tcPats :: (Name -> TcType -> TcM s TcId) -- How to deal with variables
+ -> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded
-> TcM s ([TcPat],
LIE, -- Required by n+k and literal pats
Bag TcTyVar,
Bag (Name, TcId), -- Ids bound by the pattern
LIE) -- Dicts bound by the pattern
-tcPats sig_fn [] tys = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
+tcPats tc_bndr [] tys = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
-tcPats sig_fn (ty:tys) (pat:pats)
- = tcPat sig_fn ty pat `thenTc` \ (pat', lie_req1, tvs1, ids1, lie_avail1) ->
- tcPats sig_fn tys pats `thenTc` \ (pats', lie_req2, tvs2, ids2, lie_avail2) ->
+tcPats tc_bndr (ty:tys) (pat:pats)
+ = tcPat tc_bndr ty pat `thenTc` \ (pat', lie_req1, tvs1, ids1, lie_avail1) ->
+ tcPats tc_bndr tys pats `thenTc` \ (pats', lie_req2, tvs2, ids2, lie_avail2) ->
returnTc (pat':pats', lie_req1 `plusLIE` lie_req2,
tvs1 `unionBags` tvs2, ids1 `unionBags` ids2,
in
tcInstTyVars (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
let
- ex_theta' = substTopTheta tenv ex_theta
- arg_tys' = map (substTopTy tenv) arg_tys
+ ex_theta' = substTheta tenv ex_theta
+ arg_tys' = map (substTy tenv) arg_tys
n_ex_tvs = length ex_tvs
ex_tvs' = take n_ex_tvs all_tvs'
------------------------------------------------------
\begin{code}
-tcConPat sig_fn pat con_name arg_pats pat_ty
+tcConPat tc_bndr pat con_name arg_pats pat_ty
= tcAddErrCtxt (patCtxt pat) $
-- Check the constructor itself
(arityErr "Constructor" data_con con_arity no_of_args) `thenTc_`
-- Check arguments
- tcPats sig_fn arg_pats arg_tys' `thenTc` \ (arg_pats', lie_req, tvs, ids, lie_avail2) ->
+ tcPats tc_bndr arg_pats arg_tys' `thenTc` \ (arg_pats', lie_req, tvs, ids, lie_avail2) ->
returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats',
lie_req,
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1993-1998
+%
+\section[TcRules]{Typechecking transformation rules}
+
+\begin{code}
+module TcRules ( tcRules ) where
+
+#include "HsVersions.h"
+
+import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..), HsTyVar(..) )
+import HsCore ( UfRuleBody(..) )
+import RnHsSyn ( RenamedHsDecl )
+import TcHsSyn ( TypecheckedRuleDecl, mkHsLet )
+import TcMonad
+import TcSimplify ( tcSimplifyRuleLhs, tcSimplifyAndCheck )
+import TcType ( zonkTcTypes, newTyVarTy_OpenKind )
+import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar )
+import TcMonoType ( tcHsType, tcHsTyVar, checkSigTyVars )
+import TcExpr ( tcExpr )
+import TcEnv ( tcExtendLocalValEnv, newLocalId,
+ tcExtendTyVarEnv
+ )
+import Inst ( LIE, emptyLIE, plusLIEs, instToId )
+import Id ( idType, idName, mkVanillaId )
+import VarSet
+import Type ( tyVarsOfTypes )
+import Bag ( bagToList )
+import Outputable
+import Util
+\end{code}
+
+\begin{code}
+tcRules :: [RenamedHsDecl] -> TcM s (LIE, [TypecheckedRuleDecl])
+tcRules decls = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, rules) ->
+ returnTc (plusLIEs lies, rules)
+
+tcRule (IfaceRuleDecl fun (UfRuleBody name vars args rhs) src_loc)
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxt (ruleCtxt name) $
+ tcVar fun `thenTc` \ fun' ->
+ tcCoreLamBndrs vars $ \ vars' ->
+ mapTc tcCoreExpr args `thenTc` \ args' ->
+ tcCoreExpr rhs `thenTc` \ rhs' ->
+ returnTc (emptyLIE, IfaceRuleDecl fun' (CoreRuleBody name vars' args' rhs') src_loc)
+
+tcRule (RuleDecl name sig_tvs vars lhs rhs src_loc)
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxt (ruleCtxt name) $
+ newTyVarTy_OpenKind `thenNF_Tc` \ rule_ty ->
+
+ -- Deal with the tyvars mentioned in signatures
+ -- Yuk to the UserTyVar
+ mapNF_Tc (tcHsTyVar . UserTyVar) sig_tvs `thenNF_Tc` \ sig_tyvars ->
+ tcExtendTyVarEnv sig_tyvars (
+
+ -- Ditto forall'd variables
+ mapNF_Tc new_id vars `thenNF_Tc` \ ids ->
+ tcExtendLocalValEnv [(idName id, id) | id <- ids] $
+
+ -- Now LHS and RHS
+ tcExpr lhs rule_ty `thenTc` \ (lhs', lhs_lie) ->
+ tcExpr rhs rule_ty `thenTc` \ (rhs', rhs_lie) ->
+
+ returnTc (ids, lhs', rhs', lhs_lie, rhs_lie)
+ ) `thenTc` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->
+
+ -- Check that LHS has no overloading at all
+ tcSimplifyRuleLhs lhs_lie `thenTc` \ (lhs_dicts, lhs_binds) ->
+ checkSigTyVars sig_tyvars `thenTc_`
+
+ -- Gather the template variables and tyvars
+ let
+ tpl_ids = map instToId (bagToList lhs_dicts) ++ ids
+ in
+
+ -- Gather type variables to quantify over
+ zonkTcTypes (rule_ty : map idType tpl_ids) `thenNF_Tc` \ zonked_tys ->
+ let
+ tpl_tvs = tyVarsOfTypes zonked_tys
+ in
+
+ -- RHS can be a bit more lenient. In particular,
+ -- we let constant dictionaries etc float outwards
+ tcSimplifyAndCheck (text "tcRule") tpl_tvs
+ lhs_dicts rhs_lie `thenTc` \ (lie', rhs_binds) ->
+
+ returnTc (lie', RuleDecl name (varSetElems tpl_tvs)
+ (map RuleBndr tpl_ids) -- yuk
+ (mkHsLet lhs_binds lhs')
+ (mkHsLet rhs_binds rhs')
+ src_loc)
+ where
+ new_id (RuleBndr var) = newTyVarTy_OpenKind `thenNF_Tc` \ ty ->
+ returnNF_Tc (mkVanillaId var ty)
+ new_id (RuleBndrSig var rn_ty) = tcHsType rn_ty `thenTc` \ ty ->
+ returnNF_Tc (mkVanillaId var ty)
+
+ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
+ doubleQuotes (ptext name)
+\end{code}
\begin{code}
module TcSimplify (
- tcSimplify, tcSimplifyAndCheck,
+ tcSimplify, tcSimplifyAndCheck, tcSimplifyRuleLhs,
tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas,
bindInstsOfLocalFuns
) where
import TcType ( TcType, TcTyVarSet, typeToTcType )
import TcUnify ( unifyTauTy )
import Id ( idType )
-import VarSet ( mkVarSet )
-
import Bag ( bagToList )
-import Class ( Class, ClassInstEnv, classBigSig, classInstEnv )
+import Class ( Class, classBigSig, classInstEnv )
import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
- isTyVarTy, substTopTheta, splitSigmaTy, tyVarsOfTypes
+ isTyVarTy, splitSigmaTy, tyVarsOfTypes
)
+import InstEnv ( InstEnv )
+import Subst ( mkTopTyVarSubst, substTheta )
import PprType ( pprConstraint )
import TysWiredIn ( unitTy )
import VarSet
-import VarEnv ( zipVarEnv )
import FiniteMap
import BasicTypes ( TopLevelFlag(..) )
import CmdLineOpts ( opt_GlasgowExts )
-> TopLevelFlag
-> TcTyVarSet -- ``Local'' type variables
-- ASSERT: this tyvar set is already zonked
- -> LIE -- Wanted
+ -> LIE -- Wanted
-> TcM s (LIE, -- Free
TcDictBinds, -- Bindings
LIE) -- Remaining wanteds; no dups
addNoInstanceErr str given_dicts dict
\end{code}
+On the LHS of transformation rules we only simplify methods and constants,
+getting dictionaries. We want to keep all of them unsimplified, to serve
+as the available stuff for the RHS of the rule.
+
+\begin{code}
+tcSimplifyRuleLhs :: LIE -> TcM s (LIE, TcDictBinds)
+tcSimplifyRuleLhs wanted_lie
+ = reduceContext (text "tcSimplRuleLhs") try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
+ ASSERT( null frees )
+ returnTc (mkLIE irreds, binds)
+ where
+ wanteds = bagToList wanted_lie
+
+ -- Reduce methods and lits only; stop as soon as we get a dictionary
+ try_me inst | isDict inst = DontReduce
+ | otherwise = ReduceMe AddToIrreds
+\end{code}
+
%************************************************************************
%* *
(clas, tys) = getDictClassTys dict
(tyvars, sc_theta, sc_sels, _, _) = classBigSig clas
- sc_theta' = substTopTheta (zipVarEnv tyvars tys) sc_theta
+ sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
add_sc avails ((super_clas, super_tys), sc_sel)
= newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
instance declarations.
\begin{code}
-tcSimplifyThetas :: (Class -> ClassInstEnv) -- How to find the ClassInstEnv
- -> ThetaType -- Wanted
- -> TcM s ThetaType -- Needed
+tcSimplifyThetas :: (Class -> InstEnv) -- How to find the InstEnv
+ -> ThetaType -- Wanted
+ -> TcM s ThetaType -- Needed
tcSimplifyThetas inst_mapper wanteds
= reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
-- True => irreducible
-- False => given, or can be derived from a given or from an irreducible
-reduceSimple :: (Class -> ClassInstEnv)
+reduceSimple :: (Class -> InstEnv)
-> ThetaType -- Given
-> ThetaType -- Wanted
-> NF_TcM s ThetaType -- Irreducible
givens_fm = foldl addNonIrred emptyFM givens
reduce_simple :: (Int,ThetaType) -- Stack
- -> (Class -> ClassInstEnv)
+ -> (Class -> InstEnv)
-> AvailsSimple
-> ThetaType
-> NF_TcM s AvailsSimple
= foldl add givens sc_theta
where
(tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas
- sc_theta = substTopTheta (zipVarEnv tyvars tys) sc_theta_tmpl
+ sc_theta = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
add givens ct = case lookupFM givens ct of
Nothing -> -- Add it and its superclasses
(_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
+addRuleLhsErr dict
+ = tcAddSrcLoc (instLoc dict) $
+ addErrTcM (tidy_env,
+ vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
+ nest 4 (pprOrigin dict),
+ ptext SLIT("LHS of a rule must have no overloading")])
+ where
+ (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
+
-- Used for top-level irreducibles
addTopInstanceErr dict
= tcAddSrcLoc (instLoc dict) $
where
(name, loc, thing)
= case decl of
- (ClassDecl _ name _ _ _ _ _ _ loc) -> (name, loc, "class")
+ (ClassDecl _ name _ _ _ _ _ _ _ loc) -> (name, loc, "class")
(TySynonym name _ _ loc) -> (name, loc, "type synonym")
(TyData NewType _ name _ _ _ _ loc) -> (name, loc, "data type")
(TyData DataType _ name _ _ _ _ loc) -> (name, loc, "newtype")
Nothing,
ATyCon (error "ATyCon: data")))
-getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _)
+getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _ _)
= mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds ->
returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds,
Just (length tyvars),
mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
-mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _)
+mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _)
= Just (decl, getUnique name, map (getUnique . fst) ctxt)
mk_cls_edges other_decl
= Nothing
mk_edges decl@(TySynonym name _ rhs _)
= (decl, getUnique name, uniqSetToList (get_ty rhs))
-mk_edges decl@(ClassDecl ctxt name _ sigs _ _ _ _ _)
+mk_edges decl@(ClassDecl ctxt name _ sigs _ _ _ _ _ _)
= (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
get_sigs sigs))
----------------------------------------------------
get_sigs sigs
- = unionManyUniqSets (mapMaybe get_sig sigs)
+ = unionManyUniqSets (map get_sig sigs)
where
- get_sig (ClassOpSig _ _ ty _) = Just (get_ty ty)
- get_sig (FixSig _) = Nothing
- get_sig other = panic "TcTyClsDecls:get_sig"
+ get_sig (ClassOpSig _ _ ty _) = get_ty ty
+ get_sig (FixSig _) = emptyUniqSet
+ get_sig other = panic "TcTyClsDecls:get_sig"
----------------------------------------------------
set_name name = unitUniqSet (getUnique name)
)
import RnHsSyn ( RenamedTyClDecl, RenamedConDecl )
import TcHsSyn ( TcMonoBinds )
-import BasicTypes ( RecFlag(..), NewOrData(..), StrictnessMark(..) )
+import BasicTypes ( RecFlag(..), NewOrData(..) )
import TcMonoType ( tcExtendTopTyVarScope, tcExtendTyVarScope,
tcHsTypeKind, tcHsType, tcHsTopType, tcHsTopBoxedType,
- tcContext
+ tcContext, tcHsTopTypeKind
)
import TcType ( zonkTcTyVarToTyVar, zonkTcThetaType )
import TcEnv ( tcLookupTy, TcTyThing(..) )
import Class ( Class )
import DataCon ( DataCon, dataConSig, mkDataCon, isNullaryDataCon,
- dataConFieldLabels, dataConId
+ dataConFieldLabels, dataConId,
+ markedStrict, notMarkedStrict, markedUnboxed
)
import MkId ( mkDataConId, mkRecordSelId, mkNewTySelId )
import Id ( getIdUnfolding )
tcTyDecl is_rec rec_vrcs (TySynonym tycon_name tyvar_names rhs src_loc)
= tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, Just arity, _) ->
tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ ->
- tcHsTopType rhs `thenTc` \ rhs_ty ->
+ tcHsTopTypeKind rhs `thenTc` \ (_, rhs_ty) ->
let
-- Construct the tycon
argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name)
Nothing -> []
Just f -> [mkFieldLabel (getName f) arg_ty (head allFieldLabelTags)]
in
- mk_data_con [NotMarkedStrict] [arg_ty] field_label
+ mk_data_con [notMarkedStrict] [arg_ty] field_label
tc_rec_con fields
= checkTc (null ex_tyvars) (exRecConErr name) `thenTc_`
in_arg_tys (clas,tys) = not $ isEmptyVarSet $
tyVarsOfTypes tys `intersectVarSet` arg_tyvars
-get_strictness (Banged _) = MarkedStrict
-get_strictness (Unbanged _) = NotMarkedStrict
-get_strictness (Unpacked _) = MarkedUnboxed bot bot
- where bot = error "get_strictness"
+get_strictness (Banged _) = markedStrict
+get_strictness (Unbanged _) = notMarkedStrict
+get_strictness (Unpacked _) = markedUnboxed
get_pty (Banged ty) = ty
get_pty (Unbanged ty) = ty
-- For the locally-defined things
-- we need to turn the unfoldings inside the Ids into bindings,
- binds = [ CoreMonoBind data_id (getUnfoldingTemplate (getIdUnfolding data_id))
+ binds | isLocallyDefined tycon
+ = [ CoreMonoBind data_id (getUnfoldingTemplate (getIdUnfolding data_id))
| data_id <- data_ids, isLocallyDefined data_id
]
+ | otherwise
+ = []
in
returnTc (data_ids, andMonoBindList binds)
where
mkAppTy, mkTyConApp,
splitDictTy_maybe, splitForAllTys, isNotUsgTy,
isTyVarTy, mkTyVarTy, mkTyVarTys,
- fullSubstTy, substTopTy,
typeCon, openTypeKind, boxedTypeKind, boxedKind, superKind, superBoxity
)
+import Subst ( Subst, mkTopTyVarSubst, substTy )
import TyCon ( tyConKind, mkPrimTyCon )
import PrimRep ( PrimRep(VoidRep) )
import VarEnv
\begin{code}
tcInstTyVars :: [TyVar]
- -> NF_TcM s ([TcTyVar], [TcType], TyVarEnv TcType)
+ -> NF_TcM s ([TcTyVar], [TcType], Subst)
tcInstTyVars tyvars
= mapNF_Tc tcInstTyVar tyvars `thenNF_Tc` \ tc_tyvars ->
let
tys = mkTyVarTys tc_tyvars
in
- returnNF_Tc (tc_tyvars, tys, zipVarEnv tyvars tys)
+ returnNF_Tc (tc_tyvars, tys, mkTopTyVarSubst tyvars tys)
+ -- Since the tyvars are freshly made,
+ -- they cannot possibly be captured by
+ -- any existing for-alls. Hence mkTopTyVarSubst
tcInstTyVar tyvar
= tcGetUnique `thenNF_Tc` \ uniq ->
= case splitForAllTys ty of
([], _) -> returnNF_Tc ([], ty) -- Nothing to do
(tyvars, rho) -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
- returnNF_Tc (tyvars', fullSubstTy tenv emptyVarSet rho)
- -- Since the tyvars are freshly made,
- -- they cannot possibly be captured by
- -- any existing for-alls. Hence emptyVarSet
+ returnNF_Tc (tyvars', substTy tenv rho)
\end{code}
mkClass,
classKey, classSelIds, classTyCon,
classSuperClassTheta,
- classBigSig, classInstEnv,
-
- ClassInstEnv
+ classBigSig, classInstEnv
) where
#include "HsVersions.h"
import {-# SOURCE #-} TyCon ( TyCon )
import {-# SOURCE #-} Type ( Type )
-import {-# SOURCE #-} SpecEnv ( SpecEnv )
+import {-# SOURCE #-} InstEnv ( InstEnv )
import Var ( Id, TyVar )
import Name ( NamedThing(..), Name )
-- They are all ordered by tag. The
-- selector ids contain unfoldings.
- ClassInstEnv -- All the instances of this class
+ InstEnv -- All the instances of this class
TyCon -- The data type constructor for dictionaries
-- of this class
-
-type ClassInstEnv = SpecEnv Id -- The Ids are dfuns
\end{code}
The @mkClass@ function fills in the indirect superclasses.
-> [(Class,[Type])] -> [Id]
-> [Id] -> [Maybe Id]
-> TyCon
- -> ClassInstEnv
+ -> InstEnv
-> Class
mkClass name tyvars super_classes superdict_sels
--- /dev/null
+_interface_ InstEnv 1
+_exports_
+InstEnv InstEnv ;
+_declarations_
+1 data InstEnv ;
+
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+\section{Class Instance environments}
+
+\begin{code}
+module InstEnv (
+ InstEnv, emptyInstEnv, addToInstEnv, lookupInstEnv
+ ) where
+
+#include "HsVersions.h"
+
+import Var ( TyVar, Id )
+import VarSet
+import VarEnv ( TyVarSubstEnv )
+import Type ( Type, tyVarsOfTypes )
+import Unify ( unifyTyListsX, matchTys )
+import Outputable
+import Maybes
+\end{code}
+
+
+%************************************************************************
+%* *
+\section{InstEnv}
+%* *
+%************************************************************************
+
+\begin{code}
+type InstEnv = [(TyVarSet, [Type], Id)]
+\end{code}
+
+In some InstEnvs overlap is prohibited; that is, no pair of templates unify.
+
+In others, overlap is permitted, but only in such a way that one can make
+a unique choice when looking up. That is, overlap is only permitted if
+one template matches the other, or vice versa. So this is ok:
+
+ [a] [Int]
+
+but this is not
+
+ (Int,a) (b,Int)
+
+If overlap is permitted, the list is kept most specific first, so that
+the first lookup is the right choice.
+
+
+For now we just use association lists.
+
+\begin{code}
+emptyInstEnv :: InstEnv
+emptyInstEnv = []
+
+isEmptyInstEnv env = null env
+\end{code}
+
+@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since the env is kept
+ordered, the first match must be the only one.
+The thing we are looking up can have an
+arbitrary "flexi" part.
+
+\begin{code}
+lookupInstEnv :: SDoc -- For error report
+ -> InstEnv -- The envt
+ -> [Type] -- Key
+ -> Maybe (TyVarSubstEnv, Id)
+
+lookupInstEnv doc env key
+ = find env
+ where
+ find [] = Nothing
+ find ((tpl_tyvars, tpl, val) : rest)
+ = case matchTys tpl_tyvars tpl key of
+ Nothing -> find rest
+ Just (subst, leftovers) -> ASSERT( null leftovers )
+ Just (subst, val)
+\end{code}
+
+@addToInstEnv@ extends a @InstEnv@, checking for overlaps.
+
+A boolean flag controls overlap reporting.
+
+True => overlap is permitted, but only if one template matches the other;
+ not if they unify but neither is
+
+\begin{code}
+addToInstEnv :: Bool -- True <=> overlap permitted
+ -> InstEnv -- Envt
+ -> [TyVar] -> [Type] -> Id -- New item
+ -> MaybeErr InstEnv -- Success...
+ ([Type], Id) -- Failure: Offending overlap
+
+addToInstEnv overlap_ok env ins_tvs ins_tys value
+ = insert env
+ where
+ ins_tv_set = mkVarSet ins_tvs
+ ins_item = (ins_tv_set, ins_tys, value)
+
+ insert [] = returnMaB [ins_item]
+ insert env@(cur_item@(tpl_tvs, tpl_tys, val) : rest)
+
+ -- FAIL if:
+ -- (a) they are the same, or
+ -- (b) they unify, and any sort of overlap is prohibited,
+ -- (c) they unify but neither is more specific than t'other
+ | identical
+ || (unifiable && not overlap_ok)
+ || (unifiable && not (ins_item_more_specific || cur_item_more_specific))
+ = failMaB (tpl_tys, val)
+
+ -- New item is an instance of current item, so drop it here
+ | ins_item_more_specific = returnMaB (ins_item : env)
+
+ -- Otherwise carry on
+ | otherwise = insert rest `thenMaB` \ rest' ->
+ returnMaB (cur_item : rest')
+ where
+ unifiable = maybeToBool (unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys)
+ ins_item_more_specific = maybeToBool (matchTys tpl_tvs tpl_tys ins_tys)
+ cur_item_more_specific = maybeToBool (matchTys ins_tv_set ins_tys tpl_tys)
+ identical = ins_item_more_specific && cur_item_more_specific
+\end{code}
+
case ty1 of
TyConApp bx [] -> ppr bx
other -> maybeParen ctxt_prec tYCON_PREC
- (ppr tycon <+> tys_w_spaces)
+ (sep [ppr tycon, nest 4 tys_w_spaces])
-- TUPLE CASE (boxed and unboxed)
-- GENERAL CASE
| otherwise
- = maybeParen ctxt_prec tYCON_PREC (hsep [ppr tycon, tys_w_spaces])
+ = maybeParen ctxt_prec tYCON_PREC (sep [ppr tycon, nest 4 tys_w_spaces])
where
tycon_uniq = tyConUnique tycon
Just ctys = maybe_dict
maybe_dict = splitDictTy_maybe ty -- Checks class and arity
tys_w_commas = sep (punctuate comma (map (ppr_ty env tOP_PREC) tys))
- tys_w_spaces = hsep (map (ppr_ty env tYCON_PREC) tys)
+ tys_w_spaces = sep (map (ppr_ty env tYCON_PREC) tys)
mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
- mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, funResultTy,
+ mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, splitFunTysN, funResultTy,
zipFunTys,
mkTyConApp, mkTyConTy, splitTyConApp_maybe,
- splitAlgTyConApp_maybe, splitAlgTyConApp,
+ splitAlgTyConApp_maybe, splitAlgTyConApp, splitRepTyConApp_maybe,
mkDictTy, splitDictTy_maybe, isDictTy,
mkSynTy, isSynTy, deNoteType,
mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
- applyTy, applyTys, isForAllTy,
- mkPiType,
+ isForAllTy, applyTy, applyTys, mkPiType,
TauType, RhoType, SigmaType, ThetaType,
isTauTy,
tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
addFreeTyVars,
- -- Substitution
- substTy, substTheta, fullSubstTy, substTyVar,
- substTopTy, substTopTheta,
-
-- Tidying up for printing
tidyType, tidyTypes,
tidyOpenType, tidyOpenTypes,
#include "HsVersions.h"
-import {-# SOURCE #-} DataCon( DataCon )
+import {-# SOURCE #-} DataCon( DataCon, dataConType )
import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
+import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
-- friends:
import Var ( Id, TyVar, IdOrTyVar, UVar,
import TyCon ( TyCon, KindCon,
mkFunTyCon, mkKindCon, mkSuperKindCon,
matchesTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon,
- isFunTyCon, isDataTyCon,
+ isFunTyCon, isDataTyCon, isNewTyCon,
isAlgTyCon, isSynTyCon, tyConArity,
tyConKind, tyConDataCons, getSynTyConDefn,
tyConPrimRep, tyConClass_maybe
type SuperKind = Type
type Kind = Type
-type TyVarSubst = TyVarEnv Type
+type TyVarSubst = TyVarEnv Type
data Type
= TyVarTy TyVar
splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
splitFunTy_maybe other = Nothing
-
splitFunTys :: Type -> ([Type], Type)
splitFunTys ty = split [] ty ty
where
split args orig_ty (NoteTy _ ty) = split args orig_ty ty
split args orig_ty ty = (reverse args, orig_ty)
+splitFunTysN :: String -> Int -> Type -> ([Type], Type)
+splitFunTysN msg orig_n orig_ty = split orig_n [] orig_ty orig_ty
+ where
+ split 0 args syn_ty ty = (reverse args, syn_ty)
+ split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res res
+ split n args syn_ty (NoteTy _ ty) = split n args syn_ty ty
+ split n args syn_ty ty = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty)
+
zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
where
isDictTy other = False
\end{code}
+splitRepTyConApp_maybe is like splitTyConApp_maybe except
+that it looks through
+ (a) for-alls, and
+ (b) newtypes
+in addition to synonyms. It's useful in the back end where we're not
+interested in newtypes anymore.
+
+\begin{code}
+splitRepTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
+splitRepTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
+splitRepTyConApp_maybe (NoteTy _ ty) = splitRepTyConApp_maybe ty
+splitRepTyConApp_maybe (ForAllTy _ ty) = splitRepTyConApp_maybe ty
+splitRepTyConApp_maybe (TyConApp tc tys)
+ | isNewTyCon tc
+ = case splitFunTy_maybe (applyTys (dataConType (head (tyConDataCons tc))) tys) of
+ Just (rep_ty, _) -> splitRepTyConApp_maybe rep_ty
+ | otherwise
+ = Just (tc,tys)
+splitRepTyConApp_maybe other = Nothing
+\end{code}
---------------------------------------------------------------------
SynTy
= ASSERT( isSynTyCon syn_tycon )
ASSERT( isNotUsgTy body )
NoteTy (SynNote (TyConApp syn_tycon tys))
- (substTopTy (zipVarEnv tyvars tys) body)
+ (substTy (mkTyVarSubst tyvars tys) body)
where
(tyvars, body) = getSynTyConDefn syn_tycon
| otherwise = mkForAllTy v ty
\end{code}
+Applying a for-all to its arguments
+
\begin{code}
applyTy :: Type -> Type -> Type
applyTy (NoteTy note@(UsgNote _) fun) arg = NoteTy note (applyTy fun arg)
applyTy (NoteTy _ fun) arg = applyTy fun arg
applyTy (ForAllTy tv ty) arg = ASSERT( isNotUsgTy arg )
- substTy (mkVarEnv [(tv,arg)]) ty
+ substTy (mkTyVarSubst [tv] [arg]) ty
applyTy other arg = panic "applyTy"
applyTys :: Type -> [Type] -> Type
applyTys fun_ty arg_tys
- = go [] fun_ty arg_tys
+ = substTy (mkTyVarSubst tvs arg_tys) ty
where
+ (tvs, ty) = split fun_ty arg_tys
+
+ split fun_ty [] = ([], fun_ty)
+ split (NoteTy _ fun_ty) args = split fun_ty args
+ split (ForAllTy tv fun_ty) (arg:args) = ASSERT2( isNotUsgTy arg, vcat (map pprType arg_tys) $$
+ text "in application of" <+> pprType fun_ty)
+ case split fun_ty args of
+ (tvs, ty) -> (tv:tvs, ty)
+ split other_ty args = panic "applyTys"
+
+{- OLD version with bogus usage stuff
+
+ ************* CHECK WITH KEITH **************
+
go env ty [] = substTy (mkVarEnv env) ty
go env (NoteTy note@(UsgNote _) fun)
args = NoteTy note (go env fun args)
go env (NoteTy _ fun) args = go env fun args
- go env (ForAllTy tv ty) (arg:args) = ASSERT2( isNotUsgTy arg, vcat ((map pprType arg_tys) ++ [text "in application of" <+> pprType fun_ty]) )
- go ((tv,arg):env) ty args
+ go env (ForAllTy tv ty) (arg:args) = go ((tv,arg):env) ty args
go env other args = panic "applyTys"
+-}
\end{code}
Note that we allow applications to be of usage-annotated- types, as an
typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
typeKind (NoteTy _ ty) = typeKind ty
typeKind (AppTy fun arg) = funResultTy (typeKind fun)
-typeKind (FunTy fun arg) = typeKindF arg
-typeKind (ForAllTy _ ty) = typeKindF ty -- We could make this a new kind polyTypeKind
- -- to prevent a forall type unifying with a
- -- boxed type variable, but I didn't think it
- -- was worth it yet.
-
--- The complication is that a *function* is boxed even if
--- its *result* type is unboxed. Seems wierd.
-
-typeKindF :: Type -> Kind
-typeKindF (NoteTy _ ty) = typeKindF ty
-typeKindF (FunTy _ ty) = typeKindF ty
-typeKindF (ForAllTy _ ty) = typeKindF ty
-typeKindF other = fix_up (typeKind other)
- where
- fix_up (TyConApp kc _) | kc == typeCon = boxedTypeKind
- -- Functions at the type level are always boxed
- fix_up (NoteTy _ kind) = fix_up kind
- fix_up kind = kind
+
+typeKind (FunTy arg res) = boxedTypeKind -- A function is boxed regardless of its result type
+ -- No functions at the type level, hence we don't need
+ -- to say (typeKind res).
+
+typeKind (ForAllTy tv ty) = typeKind ty
\end{code}
%************************************************************************
%* *
-\subsection{Instantiating a type}
-%* *
-%************************************************************************
-
-@substTy@ applies a substitution to a type. It deals correctly with name capture.
-
-\begin{code}
-substTy :: TyVarSubst -> Type -> Type
-substTy tenv ty
- | isEmptyVarEnv tenv = ty
- | otherwise = subst_ty tenv tset ty
- where
- tset = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet tenv
- -- If ty doesn't have any for-alls, then this thunk
- -- will never be evaluated
-
-substTheta :: TyVarSubst -> ThetaType -> ThetaType
-substTheta tenv theta
- | isEmptyVarEnv tenv = theta
- | otherwise = [(clas, map (subst_ty tenv tset) tys) | (clas, tys) <- theta]
- where
- tset = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet tenv
- -- If ty doesn't have any for-alls, then this thunk
- -- will never be evaluated
-
-substTopTy :: TyVarSubst -> Type -> Type
-substTopTy = substTy -- Called when doing top-level substitutions.
- -- Here we expect that the free vars of the range of the
- -- substitution will be empty; but during typechecking I'm
- -- a bit dubious about that (mutable tyvars bouund to Int, say)
- -- So I've left it as substTy for the moment. SLPJ Nov 98
-substTopTheta = substTheta
-\end{code}
-
-@fullSubstTy@ is like @substTy@ except that it needs to be given a set
-of in-scope type variables. In exchange it's a bit more efficient, at least
-if you happen to have that set lying around.
-
-\begin{code}
-fullSubstTy :: TyVarSubst -- Substitution to apply
- -> TyVarSet -- Superset of the free tyvars of
- -- the range of the tyvar env
- -> Type -> Type
--- ASSUMPTION: The substitution is idempotent.
--- Equivalently: No tyvar is both in scope, and in the domain of the substitution.
-fullSubstTy tenv tset ty | isEmptyVarEnv tenv = ty
- | otherwise = subst_ty tenv tset ty
-
--- subst_ty does the business
-subst_ty tenv tset ty
- = go ty
- where
- go (TyConApp tc tys) = let args = map go tys
- in args `seqList` TyConApp tc args
- go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
- go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
- go (NoteTy (UsgNote usg) ty2) = (NoteTy $! (UsgNote usg)) $! (go ty2) -- Keep usage annot
- go (FunTy arg res) = FunTy (go arg) (go res)
- go (AppTy fun arg) = mkAppTy (go fun) (go arg)
- go ty@(TyVarTy tv) = case (lookupVarEnv tenv tv) of
- Nothing -> ty
- Just ty' -> ty'
- go (ForAllTy tv ty) = case substTyVar tenv tset tv of
- (tenv', tset', tv') -> ForAllTy tv' $! (subst_ty tenv' tset' ty)
-
-substTyVar :: TyVarSubst -> TyVarSet -> TyVar
- -> (TyVarSubst, TyVarSet, TyVar)
-
-substTyVar tenv tset tv
- | not (tv `elemVarSet` tset) -- No need to clone
- -- But must delete from substitution
- = (tenv `delVarEnv` tv, tset `extendVarSet` tv, tv)
-
- | otherwise -- The forall's variable is in scope so
- -- we'd better rename it away from the in-scope variables
- -- Extending the substitution to do this renaming also
- -- has the (correct) effect of discarding any existing
- -- substitution for that variable
- = (extendVarEnv tenv tv (TyVarTy tv'), tset `extendVarSet` tv', tv')
- where
- tv' = uniqAway tset tv
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{TidyType}
%* *
%************************************************************************
use an explicit substitution
\begin{code}
-module Unify ( Subst,
- unifyTysX, unifyTyListsX,
- matchTy, matchTys
+module Unify ( unifyTysX, unifyTyListsX,
+ match, matchTy, matchTys
) where
-import Var ( TyVar, tyVarKind )
-import VarEnv
-import VarSet ( varSetElems )
import Type ( Type(..), funTyCon, typeKind, tyVarsOfType,
splitAppTy_maybe
)
+
+import Var ( TyVar, tyVarKind )
+import VarSet
+import VarEnv ( TyVarSubstEnv, emptySubstEnv, lookupSubstEnv, extendSubstEnv,
+ SubstResult(..)
+ )
+
import Unique ( Uniquable(..) )
import Outputable( panic )
import Util ( snocView )
Unify types with an explicit substitution and no monad.
\begin{code}
-type Subst
- = ([TyVar], -- Set of template tyvars
- TyVarEnv Type) -- Not necessarily idempotent
+type MySubst
+ = (TyVarSet, -- Set of template tyvars
+ TyVarSubstEnv) -- Not necessarily idempotent
-unifyTysX :: [TyVar] -- Template tyvars
+unifyTysX :: TyVarSet -- Template tyvars
-> Type
-> Type
- -> Maybe (TyVarEnv Type)
+ -> Maybe TyVarSubstEnv
unifyTysX tmpl_tyvars ty1 ty2
- = uTysX ty1 ty2 (\(_,s) -> Just s) (tmpl_tyvars, emptyVarEnv)
+ = uTysX ty1 ty2 (\(_,s) -> Just s) (tmpl_tyvars, emptySubstEnv)
-unifyTyListsX :: [TyVar] -> [Type] -> [Type]
- -> Maybe (TyVarEnv Type)
+unifyTyListsX :: TyVarSet -> [Type] -> [Type]
+ -> Maybe TyVarSubstEnv
unifyTyListsX tmpl_tyvars tys1 tys2
- = uTyListsX tys1 tys2 (\(_,s) -> Just s) (tmpl_tyvars, emptyVarEnv)
+ = uTyListsX tys1 tys2 (\(_,s) -> Just s) (tmpl_tyvars, emptySubstEnv)
uTysX :: Type
-> Type
- -> (Subst -> Maybe result)
- -> Subst
+ -> (MySubst -> Maybe result)
+ -> MySubst
-> Maybe result
uTysX (NoteTy _ ty1) ty2 k subst = uTysX ty1 ty2 k subst
| tyvar1 == tyvar2
= k subst
uTysX (TyVarTy tyvar1) ty2 k subst@(tmpls,_)
- | tyvar1 `elem` tmpls
+ | tyvar1 `elemVarSet` tmpls
= uVarX tyvar1 ty2 k subst
uTysX ty1 (TyVarTy tyvar2) k subst@(tmpls,_)
- | tyvar2 `elem` tmpls
+ | tyvar2 `elemVarSet` tmpls
= uVarX tyvar2 ty1 k subst
-- Functions; just check the two parts
\begin{code}
-- Invariant: tv1 is a unifiable variable
uVarX tv1 ty2 k subst@(tmpls, env)
- = case lookupVarEnv env tv1 of
- Just ty1 -> -- Already bound
+ = case lookupSubstEnv env tv1 of
+ Just (DoneTy ty1) -> -- Already bound
uTysX ty1 ty2 k subst
Nothing -- Not already bound
| typeKind ty2 == tyVarKind tv1
&& occur_check_ok ty2
-> -- No kind mismatch nor occur check
- k (tmpls, extendVarEnv env tv1 ty2)
+ k (tmpls, extendSubstEnv env tv1 (DoneTy ty2))
| otherwise -> Nothing -- Fail if kind mis-match or occur check
where
occur_check_ok ty = all occur_check_ok_tv (varSetElems (tyVarsOfType ty))
occur_check_ok_tv tv | tv1 == tv = False
- | otherwise = case lookupVarEnv env tv of
- Nothing -> True
- Just ty -> occur_check_ok ty
+ | otherwise = case lookupSubstEnv env tv of
+ Nothing -> True
+ Just (DoneTy ty) -> occur_check_ok ty
\end{code}
types.
\begin{code}
-matchTy :: [TyVar] -- Template tyvars
+matchTy :: TyVarSet -- Template tyvars
-> Type -- Template
-> Type -- Proposed instance of template
- -> Maybe (TyVarEnv Type) -- Matching substitution
+ -> Maybe TyVarSubstEnv -- Matching substitution
-matchTys :: [TyVar] -- Template tyvars
+matchTys :: TyVarSet -- Template tyvars
-> [Type] -- Templates
-> [Type] -- Proposed instance of template
- -> Maybe (TyVarEnv Type, -- Matching substitution
+ -> Maybe (TyVarSubstEnv, -- Matching substitution
[Type]) -- Left over instance types
-matchTy tmpls ty1 ty2 = match ty1 ty2 (\(_,env) -> Just env)
- (tmpls, emptyVarEnv)
+matchTy tmpls ty1 ty2 = match ty1 ty2 tmpls (\ senv -> Just senv) emptySubstEnv
-matchTys tmpls tys1 tys2 = match_list tys1 tys2 (\((_,env),tys) -> Just (env,tys))
- (tmpls, emptyVarEnv)
+matchTys tmpls tys1 tys2 = match_list tys1 tys2 tmpls
+ (\ (senv,tys) -> Just (senv,tys))
+ emptySubstEnv
\end{code}
@match@ is the main function.
\begin{code}
-match :: Type -> Type -- Current match pair
- -> (Subst -> Maybe result) -- Continuation
- -> Subst -- Current substitution
+match :: Type -> Type -- Current match pair
+ -> TyVarSet -- Template vars
+ -> (TyVarSubstEnv -> Maybe result) -- Continuation
+ -> TyVarSubstEnv -- Current subst
-> Maybe result
-- When matching against a type variable, see if the variable
-- has already been bound. If so, check that what it's bound to
-- is the same as ty; if not, bind it and carry on.
-match (TyVarTy v) ty k = \ s@(tmpls,env) ->
- if v `elem` tmpls then
- -- v is a template variable
- case lookupVarEnv env v of
- Nothing -> k (tmpls, extendVarEnv env v ty)
- Just ty' | ty' == ty -> k s -- Succeeds
- | otherwise -> Nothing -- Fails
- else
- -- v is not a template variable; ty had better match
- -- Can't use (==) because types differ
- case ty of
- TyVarTy v' | getUnique v == getUnique v'
- -> k s -- Success
- other -> Nothing -- Failure
-
-match (FunTy arg1 res1) (FunTy arg2 res2) k = match arg1 arg2 (match res1 res2 k)
-match (AppTy fun1 arg1) ty2 k = case splitAppTy_maybe ty2 of
- Just (fun2,arg2) -> match fun1 fun2 (match arg1 arg2 k)
- Nothing -> \ _ -> Nothing -- Fail
-match (TyConApp tc1 tys1) (TyConApp tc2 tys2) k | tc1 == tc2
- = match_list tys1 tys2 ( \(s,tys2') ->
- if null tys2' then
- k s -- Succeed
- else
- Nothing -- Fail
- )
+match (TyVarTy v) ty tmpls k senv
+ | v `elemVarSet` tmpls
+ = -- v is a template variable
+ case lookupSubstEnv senv v of
+ Nothing -> k (extendSubstEnv senv v (DoneTy ty))
+ Just (DoneTy ty') | ty' == ty -> k senv -- Succeeds
+ | otherwise -> Nothing -- Fails
+
+ | otherwise
+ = -- v is not a template variable; ty had better match
+ -- Can't use (==) because types differ
+ case ty of
+ TyVarTy v' | v == v' -> k senv -- Success
+ other -> Nothing -- Failure
+
+match (FunTy arg1 res1) (FunTy arg2 res2) tmpls k senv
+ = match arg1 arg2 tmpls (match res1 res2 tmpls k) senv
+
+match (AppTy fun1 arg1) ty2 tmpls k senv
+ = case splitAppTy_maybe ty2 of
+ Just (fun2,arg2) -> match fun1 fun2 tmpls (match arg1 arg2 tmpls k) senv
+ Nothing -> Nothing -- Fail
+
+match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv
+ | tc1 == tc2
+ = match_list tys1 tys2 tmpls k' senv
+ where
+ k' (senv', tys2') | null tys2' = k senv' -- Succeed
+ | otherwise = Nothing -- Fail
-- With type synonyms, we have to be careful for the exact
-- same reasons as in the unifier. Please see the
-- considerable commentary there before changing anything
-- here! (WDP 95/05)
-match (NoteTy _ ty1) ty2 k = match ty1 ty2 k
-match ty1 (NoteTy _ ty2) k = match ty1 ty2 k
+match (NoteTy _ ty1) ty2 tmpls k senv = match ty1 ty2 tmpls k senv
+match ty1 (NoteTy _ ty2) tmpls k senv = match ty1 ty2 tmpls k senv
-- Catch-all fails
-match _ _ _ = \s -> Nothing
+match _ _ _ _ _ = Nothing
-match_list [] tys2 k = \s -> k (s, tys2)
-match_list (ty1:tys1) [] k = \s -> Nothing -- Not enough arg tys => failure
-match_list (ty1:tys1) (ty2:tys2) k = match ty1 ty2 (match_list tys1 tys2 k)
+match_list [] tys2 tmpls k senv = k (senv, tys2)
+match_list (ty1:tys1) [] tmpls k senv = Nothing -- Not enough arg tys => failure
+match_list (ty1:tys1) (ty2:tys2) tmpls k senv = match ty1 ty2 tmpls (match_list tys1 tys2 tmpls k) senv
\end{code}
mungeTerm (Note (TermUsg (UsVar uv)) (Lam v e))
-- perform substitution *and* munge annot on lambda into IdInfo.lbvarInfo
= let lb = case (s uv) of { UsOnce -> IsOneShotLambda; UsMany -> NoLBVarInfo }
- v' = modifyIdInfo v (setLBVarInfo lb) -- HACK ALERT!
+ v' = modifyIdInfo (`setLBVarInfo` lb) v -- HACK ALERT!
-- see comment in IdInfo.lhs; this is because the info is easier to
-- access here, by agreement SLPJ/KSW 1999-04 (as a "short-term hack").
in return (Lam v' e)
import CoreSyn
import Const ( Con(..), Literal(..) )
import Var ( IdOrTyVar, varName, varType, setVarType, mkUVar )
-import Id ( idMustBeINLINEd )
-import Name ( isLocallyDefined, isExported )
-import Type ( Type(..), TyNote(..), UsageAnn(..), isUsgTy, substTy, splitFunTys )
+import Id ( idMustBeINLINEd, isExportedId )
+import Name ( isLocallyDefined )
+import Type ( Type(..), TyNote(..), UsageAnn(..), isUsgTy, splitFunTys )
+import Subst ( substTy, mkTyVarSubst )
import TyCon ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon )
import VarEnv
import PrimOp ( PrimOp, primOpUsg )
tauTyMF loc = MungeFlags { isSigma = False, isLocal = True,
hasUsg = False, isExp = False, mfLoc = loc }
sigVarTyMF v = MungeFlags { isSigma = True, isLocal = hasLocalDef v,
- hasUsg = hasUsgInfo v, isExp = isExported v,
+ hasUsg = hasUsgInfo v, isExp = isExportedId v,
mfLoc = ptext SLIT("type of binder") <+> ppr v }
\end{code}
-- and returns this (sigma) type
primOpUsgTys p tys = let (tyvs,ty0us,rtyu) = primOpUsg p
- s = zipVarEnv tyvs tys
+ s = mkTyVarSubst tyvs tys
(ty1us,rty1u) = splitFunTys (substTy s rtyu)
-- substitution may reveal more args
in ((map (substTy s) ty0us) ++ ty1us,
-- Maybe(..), -- no, it's in 1.3
MaybeErr(..),
+ orElse,
mapMaybe,
allMaybes,
firstJust,
#include "HsVersions.h"
import Maybe( catMaybes, mapMaybe )
+
+
+infixr 4 `orElse`
\end{code}
failMaybe :: Maybe a
failMaybe = Nothing
+
+orElse :: Maybe a -> a -> a
+(Just x) `orElse` y = x
+Nothing `orElse` y = y
\end{code}
Lookup functions
pprAndThen :: (String -> a) -> String -> SDoc -> a
pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
where
- doc = text heading <+> pretty_msg
+ doc = sep [text heading, nest 4 pretty_msg]
assertPprPanic :: String -> Int -> SDoc -> a
assertPprPanic file line msg
transitiveClosure,
-- accumulating
- mapAccumL, mapAccumR, mapAccumB,
+ mapAccumL, mapAccumR, mapAccumB, foldl2, count,
-- comparisons
thenCmp, cmpList,
#else
zipEqual msg [] [] = []
zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
-zipEqual msg as bs = panic ("zipEqual: unequal lists: "++msg)
+zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
zipWithEqual msg _ [] [] = []
-zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists: "++msg)
+zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
zipWith3Equal msg z (a:as) (b:bs) (c:cs)
= z a b c : zipWith3Equal msg z as bs cs
zipWith3Equal msg _ [] [] [] = []
-zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists: "++msg)
+zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
= z a b c d : zipWith4Equal msg z as bs cs ds
zipWith4Equal msg _ [] [] [] [] = []
-zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg)
+zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
#endif
\end{code}
nOfThem n thing = replicate n thing
lengthExceeds :: [a] -> Int -> Bool
-
-[] `lengthExceeds` n = 0 > n
-(x:xs) `lengthExceeds` n = (1 > n) || (xs `lengthExceeds` (n - 1))
+-- (lengthExceeds xs n) is True if length xs > n
+(x:xs) `lengthExceeds` n = n < 1 || xs `lengthExceeds` (n - 1)
+[] `lengthExceeds` n = n < 0
isSingleton :: [a] -> Bool
-
isSingleton [x] = True
isSingleton _ = False
(a'',b',ys) = mapAccumB f a' b xs
\end{code}
+A combination of foldl with zip. It works with equal length lists.
+
+\begin{code}
+foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
+foldl2 k z [] [] = z
+foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
+\end{code}
+
+Count the number of times a predicate is true
+
+\begin{code}
+count :: (a -> Bool) -> [a] -> Int
+count p [] = 0
+count p (x:xs) | p x = 1 + count p xs
+ | otherwise = count p xs
+\end{code}
+
+
%************************************************************************
%* *
\subsection[Utils-comparison]{Comparisons}
\end{code}
-y
%************************************************************************
%* *
\subsection[Utils-pairs]{Pairs}
projects / ghc-hetmet.git / commitdiff