+Notes July 00
+~~~~~~~~~~~~~~
+Time.lhs: fails with too many arguments to C function
+works with native code gen
+
+CTypes.lhs: fails with
+ /tmp/ghc2840.hc:42413: fixed or forbidden register 3 (bx) was spilled for class GENERAL_REGS.
+ This may be due to a compiler bug or to impossible asm statements or clauses.
+works without -O
+
+posix/* fails with
+ ghc1653.c:4: `#include' expects "FILENAME" or <FILENAME>
+ ghc1653.c:6: `#include' expects "FILENAME" or <FILENAME>
+works when one fixes the makefile
+
+make depend needs the -osuf o removed.
+
+CTypes also has a Subst-worker WARNING.
+
+
Notes June 99
~~~~~~~~~~~~~
* In nofib/spectral/mandel2/Main.check_radius, there's a call to (fromIntegral m), where
( Literal(..) -- Exported to ParseIface
, mkMachInt, mkMachWord
, mkMachInt64, mkMachWord64
- , isLitLitLit, maybeLitLit
+ , isLitLitLit, maybeLitLit, litIsDupable,
, literalType, literalPrimRep
, hashLiteral
maybeLitLit (MachLitLit s t) = Just (s,t)
maybeLitLit _ = Nothing
+
+litIsDupable :: Literal -> Bool
+ -- True if code space does not go bad if we duplicate this literal
+ -- False principally of strings
+litIsDupable (MachStr _) = False
+litIsDupable other = True
\end{code}
Types
SubstEnv, TyVarSubstEnv, SubstResult(..),
emptySubstEnv,
mkSubstEnv, lookupSubstEnv, extendSubstEnv, extendSubstEnvList,
- delSubstEnv, noTypeSubst, isEmptySubstEnv
+ delSubstEnv, delSubstEnvList, noTypeSubst, isEmptySubstEnv
) where
#include "HsVersions.h"
delSubstEnv :: SubstEnv -> Var -> SubstEnv
delSubstEnv (SE s nt) v = SE (delVarEnv s v) nt
+
+delSubstEnvList :: SubstEnv -> [Var] -> SubstEnv
+delSubstEnvList (SE s nt) vs = SE (delVarEnvList s vs) nt
\end{code}
intersectVarSet, intersectsVarSet,
isEmptyVarSet, delVarSet, delVarSetByKey,
minusVarSet, foldVarSet, filterVarSet,
- lookupVarSet, mapVarSet, sizeVarSet, seqVarSet,
-
- uniqAway
+ lookupVarSet, mapVarSet, sizeVarSet, seqVarSet
) where
#include "HsVersions.h"
import CmdLineOpts ( opt_PprStyle_Debug )
import Var ( Var, Id, TyVar, UVar, setVarUnique )
-import Unique ( Unique, Uniquable(..), incrUnique, deriveUnique )
+import Unique ( Unique, Uniquable(..) )
import UniqSet
import UniqFM ( delFromUFM_Directly )
import Outputable
seqVarSet s = sizeVarSet s `seq` ()
\end{code}
-\begin{code}
-uniqAway :: VarSet -> Var -> Var
--- Give the Var a new unique, different to any in the VarSet
-uniqAway set var
- | not (var `elemVarSet` set) = var -- Nothing to do
-
- | otherwise
- = try 1 (deriveUnique (getUnique var) (hashUniqSet set))
- where
- try n uniq | uniq `elemUniqSet_Directly` set = try ((n+1)::Int) (incrUnique uniq)
-#ifdef DEBUG
- | opt_PprStyle_Debug && n > 3
- = pprTrace "uniqAway:" (ppr n <+> text "tries" <+> ppr var)
- setVarUnique var uniq
-#endif
- | otherwise = setVarUnique var uniq
-\end{code}
isPrimOpId_maybe
)
import VarSet
-import Literal ( isLitLitLit )
+import Literal ( isLitLitLit, litIsDupable )
import PrimOp ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm )
import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..), CprInfo(..),
insideLam, workerExists, isNeverInlinePrag
size_up (App fun (Type t)) = size_up fun
size_up (App fun arg) = size_up_app fun [arg]
- size_up (Lit lit) = sizeOne
+ size_up (Lit lit) | litIsDupable lit = sizeOne
+ | otherwise = sizeN opt_UF_DearOp -- For lack of anything better
size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 1)
| otherwise = size_up e
where
rhs_size = foldr (addSize . size_up . snd) sizeZero pairs
- -- We want to make wrapper-style evaluation look cheap, so that
- -- when we inline a wrapper it doesn't make call site (much) bigger
- -- Otherwise we get nasty phase ordering stuff:
- -- f x = g x x
- -- h y = ...(f e)...
- -- If we inline g's wrapper, f looks big, and doesn't get inlined
- -- into h; if we inline f first, while it looks small, then g's
- -- wrapper will get inlined later anyway. To avoid this nasty
- -- ordering difference, we make (case a of (x,y) -> ...) look free.
- size_up (Case (Var v) _ [alt])
- | v `elem` top_args
- = size_up_alt alt `addSize` SizeIs 0# (unitBag (v, 1)) 0#
+ size_up (Case (Var v) _ alts)
+ | v `elem` top_args -- We are scrutinising an argument variable
+ = case alts of
+ [alt] -> size_up_alt alt `addSize` SizeIs 0# (unitBag (v, 1)) 0#
+ -- We want to make wrapper-style evaluation look cheap, so that
+ -- when we inline a wrapper it doesn't make call site (much) bigger
+ -- Otherwise we get nasty phase ordering stuff:
+ -- f x = g x x
+ -- h y = ...(f e)...
+ -- If we inline g's wrapper, f looks big, and doesn't get inlined
+ -- into h; if we inline f first, while it looks small, then g's
+ -- wrapper will get inlined later anyway. To avoid this nasty
+ -- ordering difference, we make (case a of (x,y) -> ...),
+ -- *where a is one of the arguments* look free.
+
+ other -> alts_size (foldr addSize sizeOne alt_sizes) -- The 1 is for the scrutinee
+ (foldr1 maxSize alt_sizes)
+
-- Good to inline if an arg is scrutinised, because
-- that may eliminate allocation in the caller
-- And it eliminates the case itself
- | otherwise
- = size_up_alt alt
-
- -- Scrutinising one of the argument variables,
- -- with more than one alternative
- size_up (Case (Var v) _ alts)
- | v `elem` top_args
- = alts_size (foldr addSize sizeOne alt_sizes) -- The 1 is for the scrutinee
- (foldr1 maxSize alt_sizes)
+
where
alt_sizes = map size_up_alt alts
+ -- alts_size tries to compute a good discount for
+ -- the case when we are scrutinising an argument variable
alts_size (SizeIs tot tot_disc tot_scrut) -- Size of all alternatives
(SizeIs max max_disc max_scrut) -- Size of biggest alternative
= SizeIs tot (unitBag (v, I# (1# +# tot -# max)) `unionBags` max_disc) max_scrut
-- If the variable is known, we produce a discount that
-- will take us back to 'max', the size of rh largest alternative
-- The 1+ is a little discount for reduced allocation in the caller
-
alts_size tot_size _ = tot_size
------------
-- We want to record if we're case'ing, or applying, an argument
fun_discount v | v `elem` top_args = SizeIs 0# (unitBag (v, opt_UF_FunAppDiscount)) 0#
- fun_discount other = sizeZero
+ fun_discount other = sizeZero
------------
-- These addSize things have to be here because
import VarSet
import VarEnv
import Name ( isLocallyDefined, hashName )
-import Literal ( Literal, hashLiteral, literalType )
+import Literal ( Literal, hashLiteral, literalType, litIsDupable )
import DataCon ( DataCon, dataConRepArity )
import PrimOp ( primOpOkForSpeculation, primOpIsCheap,
primOpIsDupable )
\begin{code}
exprIsDupable (Type _) = True
exprIsDupable (Var v) = True
-exprIsDupable (Lit lit) = True
+exprIsDupable (Lit lit) = litIsDupable lit
exprIsDupable (Note _ e) = exprIsDupable e
exprIsDupable expr
= go expr 0
\begin{code}
module Subst (
-- In-scope set
- InScopeSet, emptyInScopeSet,
- lookupInScope, setInScope, extendInScope, extendInScopes, isInScope, modifyInScope,
+ InScopeSet, emptyInScopeSet, mkInScopeSet,
+ extendInScopeSet, extendInScopeSetList,
+ lookupInScope, elemInScopeSet, uniqAway,
+
-- Substitution stuff
Subst, TyVarSubst, IdSubst,
emptySubst, mkSubst, substEnv, substInScope,
lookupSubst, lookupIdSubst, isEmptySubst, extendSubst, extendSubstList,
zapSubstEnv, setSubstEnv,
+ setInScope,
+ extendInScope, extendInScopeList, extendNewInScope, extendNewInScopeList,
+ isInScope, modifyInScope,
bindSubst, unBindSubst, bindSubstList, unBindSubstList,
#include "HsVersions.h"
+import CmdLineOpts ( opt_PprStyle_Debug )
import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr,
CoreRules(..), CoreRule(..),
emptyCoreRules, isEmptyCoreRules, seqRules
specInfo, setSpecInfo,
WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo
)
+import Unique ( Uniquable(..), deriveUnique )
+import UniqSet ( elemUniqSet_Directly )
import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply )
import Var ( Var, Id, TyVar, isTyVar )
import Outputable
import Util ( mapAccumL, foldl2, seqList, ($!) )
\end{code}
+
%************************************************************************
%* *
-\subsection{Substitutions}
+\subsection{The in-scope set}
%* *
%************************************************************************
\begin{code}
-type InScopeSet = VarEnv Var
+data InScopeSet = InScope (VarEnv Var) Int#
+ -- The Int# is a kind of hash-value used by uniqAway
+ -- For example, it might be the size of the set
+
+emptyInScopeSet :: InScopeSet
+emptyInScopeSet = InScope emptyVarSet 0#
+
+mkInScopeSet :: VarEnv Var -> InScopeSet
+mkInScopeSet in_scope = InScope in_scope 0#
+
+extendInScopeSet :: InScopeSet -> Var -> InScopeSet
+extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#)
+
+extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
+extendInScopeSetList (InScope in_scope n) vs = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
+ (case length vs of { I# l -> n +# l })
+
+modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
+-- Exploit the fact that the in-scope "set" is really a map
+-- Make old_v map to new_v
+modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#)
+
+delInScopeSet :: InScopeSet -> Var -> InScopeSet
+delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
+
+elemInScopeSet :: Var -> InScopeSet -> Bool
+elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope
+
+lookupInScope :: InScopeSet -> Var -> Var
+-- It's important to look for a fixed point
+-- When we see (case x of y { I# v -> ... })
+-- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
+-- When we lookup up an occurrence of x, we map to y, but then
+-- we want to look up y in case it has acquired more evaluation information by now.
+lookupInScope (InScope in_scope n) v
+ = go v
+ where
+ go v = case lookupVarEnv in_scope v of
+ Just v' | v == v' -> v' -- Reached a fixed point
+ | otherwise -> go v'
+ Nothing -> WARN( mustHaveLocalBinding v, ppr v )
+ v
+\end{code}
+
+\begin{code}
+uniqAway :: InScopeSet -> Var -> Var
+-- (uniqAway in_scope v) finds a unique that is not used in the
+-- in-scope set, and gives that to v. It starts with v's current unique, of course,
+-- in the hope that it won't have to change it, nad thereafter uses a combination
+-- of that and the hash-code found in the in-scope set
+uniqAway (InScope set n) var
+ | not (var `elemVarSet` set) = var -- Nothing to do
+ | otherwise = try 1#
+ where
+ orig_unique = getUnique var
+ try k | uniq `elemUniqSet_Directly` set = try (k +# 1#)
+#ifdef DEBUG
+ | opt_PprStyle_Debug && k ># 3#
+ = pprTrace "uniqAway:" (ppr (I# k) <+> text "tries" <+> ppr var <+> int (I# n))
+ setVarUnique var uniq
+#endif
+ | otherwise = setVarUnique var uniq
+ where
+ uniq = deriveUnique orig_unique (I# (n *# k))
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Substitutions}
+%* *
+%************************************************************************
+
+\begin{code}
data Subst = Subst InScopeSet -- In scope
SubstEnv -- Substitution itself
-- INVARIANT 1: The (domain of the) in-scope set is a superset
case y of x { ... }
That's why the "set" is actually a VarEnv Var
-\begin{code}
-emptyInScopeSet :: InScopeSet
-emptyInScopeSet = emptyVarSet
-
-add_in_scope :: InScopeSet -> Var -> InScopeSet
-add_in_scope in_scope v = extendVarEnv in_scope v v
-\end{code}
-
-
\begin{code}
isEmptySubst :: Subst -> Bool
where
v' = lookupInScope in_scope v
-lookupInScope :: InScopeSet -> Var -> Var
--- It's important to look for a fixed point
--- When we see (case x of y { I# v -> ... })
--- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
--- When we lookup up an occurrence of x, we map to y, but then
--- we want to look up y in case it has acquired more evaluation information by now.
-lookupInScope in_scope v
- = case lookupVarEnv in_scope v of
- Just v' | v == v' -> v' -- Reached a fixed point
- | otherwise -> lookupInScope in_scope v'
- Nothing -> WARN( mustHaveLocalBinding v, ppr v )
- v
-
isInScope :: Var -> Subst -> Bool
-isInScope v (Subst in_scope _) = v `elemVarEnv` in_scope
-
-extendInScope :: Subst -> Var -> Subst
-extendInScope (Subst in_scope env) v = Subst (in_scope `add_in_scope` v) env
+isInScope v (Subst in_scope _) = v `elemInScopeSet` in_scope
modifyInScope :: Subst -> Var -> Var -> Subst
-modifyInScope (Subst in_scope env) old_v new_v = Subst (extendVarEnv in_scope old_v new_v) env
+modifyInScope (Subst in_scope env) old_v new_v = Subst (modifyInScopeSet in_scope old_v new_v) env
-- make old_v map to new_v
-extendInScopes :: Subst -> [Var] -> Subst
-extendInScopes (Subst in_scope env) vs = Subst (foldl add_in_scope in_scope vs) env
+extendInScope :: Subst -> Var -> Subst
+ -- Add a new variable as in-scope
+ -- Remember to delete any existing binding in the substitution!
+extendInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v)
+ (env `delSubstEnv` v)
+
+extendInScopeList :: Subst -> [Var] -> Subst
+extendInScopeList (Subst in_scope env) vs = Subst (extendInScopeSetList in_scope vs)
+ (delSubstEnvList env vs)
+
+-- The "New" variants are guaranteed to be adding freshly-allocated variables
+-- It's not clear that the gain (not needing to delete it from the substitution)
+-- is worth the extra proof obligation
+extendNewInScope :: Subst -> Var -> Subst
+extendNewInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v) env
+
+extendNewInScopeList :: Subst -> [Var] -> Subst
+extendNewInScopeList (Subst in_scope env) vs = Subst (in_scope `extendInScopeSetList` 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 `add_in_scope` new_bndr)
+ = Subst (in_scope `extendInScopeSet` new_bndr)
(extendSubstEnv env old_bndr subst_result)
where
subst_result | isId old_bndr = DoneEx (Var new_bndr)
-- 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 `delVarEnv` new_bndr) (delSubstEnv env old_bndr)
+ = Subst (in_scope `delInScopeSet` new_bndr) (delSubstEnv env old_bndr)
-- And the "List" forms
bindSubstList :: Subst -> [Var] -> [Var] -> Subst
%************************************************************************
\begin{code}
-type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
+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)
+mkTyVarSubst tyvars tys = Subst (mkInScopeSet (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
--
-- 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 `add_in_scope` new_var)
+ = (Subst (in_scope `extendInScopeSet` new_var)
(delSubstEnv env old_var),
new_var)
-- Extending the substitution to do this renaming also
-- has the (correct) effect of discarding any existing
-- substitution for that variable
- = (Subst (in_scope `add_in_scope` new_var)
+ = (Subst (in_scope `extendInScopeSet` new_var)
(extendSubstEnv env old_var (DoneTy (TyVarTy new_var))),
new_var)
where
-- top of this module
substId subst@(Subst in_scope env) old_id
- = (Subst (in_scope `add_in_scope` new_id) new_env, new_id)
+ = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
where
id_ty = idType old_id
occ_info = idOccInfo old_id
substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, UniqSupply, Id)
substAndCloneId subst@(Subst in_scope env) us old_id
- = (Subst (in_scope `add_in_scope` new_id)
+ = (Subst (in_scope `extendInScopeSet` new_id)
(extendSubstEnv env old_id (DoneEx (Var new_id))),
new_us,
new_id)
import TcModule ( TcResults(..) )
import CoreSyn
import Rules ( ProtoCoreRule(..), pprProtoCoreRule )
-import Subst ( substExpr, mkSubst )
+import Subst ( substExpr, mkSubst, mkInScopeSet )
import DsMonad
import DsExpr ( dsExpr )
import DsBinds ( dsMonoBinds, AutoScc(..) )
(Rule name tpl_vars args core_rhs))
where
tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars]
- all_vars = in_scope `unionVarSet` mkVarSet tpl_vars
+ all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars)
ds_lhs all_vars lhs
= let
SrcLoc
| ClassOpSig name -- Selector name
- name -- Default-method name (if any)
- Bool -- True <=> there is an explicit, programmer-supplied
- -- default declaration in the class decl
+ (Maybe -- Nothing for source-file class signatures
+ (name, -- Default-method name (if any)
+ Bool)) -- True <=> there is an explicit, programmer-supplied
+ -- default declaration in the class decl
(HsType name)
SrcLoc
\begin{code}
okBindSig :: NameSet -> Sig Name -> Bool
-okBindSig ns (ClassOpSig _ _ _ _ _) = False
+okBindSig ns (ClassOpSig _ _ _ _) = False
okBindSig ns sig = sigForThisGroup ns sig
okClsDclSig :: NameSet -> Sig Name -> Bool
sigName :: Sig name -> Maybe name
sigName (Sig n _ _) = Just n
-sigName (ClassOpSig n _ _ _ _) = Just n
+sigName (ClassOpSig n _ _ _) = Just n
sigName (SpecSig n _ _) = Just n
sigName (InlineSig n _ _) = Just n
sigName (NoInlineSig n _ _) = Just n
isFixitySig _ = False
isClassOpSig :: Sig name -> Bool
-isClassOpSig (ClassOpSig _ _ _ _ _) = True
-isClassOpSig _ = False
+isClassOpSig (ClassOpSig _ _ _ _) = True
+isClassOpSig _ = False
isPragSig :: Sig name -> Bool
-- Identifies pragmas
\begin{code}
hsSigDoc (Sig _ _ loc) = (SLIT("type signature"),loc)
-hsSigDoc (ClassOpSig _ _ _ _ loc) = (SLIT("class-method type signature"), loc)
+hsSigDoc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
hsSigDoc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
hsSigDoc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc)
hsSigDoc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc)
ppr_sig (Sig var ty _)
= sep [ppr var <+> dcolon, nest 4 (ppr ty)]
-ppr_sig (ClassOpSig var _ dm ty _)
+ppr_sig (ClassOpSig var dm ty _)
= sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)]
where
- pp_dm = if dm then equals else empty -- Default-method indicator
+ pp_dm = case dm of
+ Just (_, True) -> equals -- Default-method indicator
+ other -> empty
ppr_sig (SpecSig var ty _)
= sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
BangType(..), getBangType,
IfaceSig(..), SpecDataSig(..),
DeprecDecl(..), DeprecTxt,
- hsDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule
+ hsDeclName, instDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule
) where
#include "HsVersions.h"
hsDeclName :: (Outputable name, Outputable pat)
=> HsDecl name pat -> name
#endif
-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
+hsDeclName (TyClD decl) = tyClDeclName decl
+hsDeclName (InstD decl) = instDeclName decl
+hsDeclName (SigD (IfaceSig 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
+
+instDeclName :: InstDecl name pat -> name
+instDeclName (InstDecl _ _ _ (Just name) _) = name
\end{code}
\begin{code}
%* *
%************************************************************************
+Type and class declarations carry 'implicit names'. In particular:
+
+Type A.
+~~~~~~~
+ Each data type decl defines
+ a worker name for each constructor
+ to-T and from-T convertors
+ Each class decl defines
+ a tycon for the class
+ a data constructor for that tycon
+ the worker for that constructor
+ a selector for each superclass
+
+All have occurrence names that are derived uniquely from their parent declaration.
+
+None of these get separate definitions in an interface file; they are
+fully defined by the data or class decl. But they may *occur* in
+interface files, of course. Any such occurrence must haul in the
+relevant type or class decl.
+
+Plan of attack:
+ - Make up their occurrence names immediately
+
+ - Ensure they "point to" the parent data/class decl
+ when loading that decl from an interface file
+
+ - When renaming the decl look them up in the name cache,
+ ensure correct module and provenance is set
+
+Type B: Default methods and dictionary functions
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Have their own binding in an interface file.
+
+Default methods : occurrence name is derived uniquely from the class decl.
+Dict functions : occurrence name is derived from the instance decl, plus a unique number.
+
+Plan of attack:
+ - Do *not* make them point to the parent class decl
+ - Interface-file decls: treat just like Type A
+ - Source-file decls: the names aren't in the decl at all;
+ instead the typechecker makes them up
+
\begin{code}
data TyClDecl name pat
= TyData NewOrData
eq_hsFD env (ns1,ms1) (ns2,ms2)
= eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2
-eq_cls_sig env (ClassOpSig n1 _ b1 ty1 _) (ClassOpSig n2 _ b2 ty2 _)
- = n1==n2 && b1==b2 && eq_hsType env ty1 ty2
+eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _)
+ = n1==n2 && dm1 `eq_dm` dm2 && eq_hsType env ty1 ty2
+ where
+ -- Ignore the name of the default method.
+ -- This is used for comparing declarations before putting
+ -- them into interface files, and the name of the default
+ -- method isn't relevant
+ (Just (_,explicit_dm1)) `eq_dm` (Just (_,explicit_dm2)) = explicit_dm1 == explicit_dm2
+ Nothing `eq_dm` Nothing = True
+ dm1 `eq_dm` dm2 = False
\end{code}
\begin{code}
[Sig name] -- User-supplied pragmatic info
- name -- Name for the dictionary function
+ (Maybe name) -- Name for the dictionary function
+ -- Nothing for source-file instance decls
SrcLoc
\end{code}
instance (Outputable name, Outputable pat)
=> Outputable (InstDecl name pat) where
- ppr (InstDecl inst_ty binds uprags dfun_name src_loc)
+ ppr (InstDecl inst_ty binds uprags maybe_dfun_name src_loc)
= getPprStyle $ \ sty ->
if ifaceStyle sty then
- hsep [ptext SLIT("instance"), ppr inst_ty, equals, ppr dfun_name]
+ hsep [ptext SLIT("instance"), ppr inst_ty, equals, pp_dfun]
else
vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
nest 4 (ppr uprags),
nest 4 (ppr binds) ]
+ where
+ pp_dfun = case maybe_dfun_name of
+ Just df -> ppr df
+ Nothing -> empty
\end{code}
\begin{code}
count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
sig_info (Sig _ _ _) = (1,0,0,0)
- sig_info (ClassOpSig _ _ _ _ _) = (0,1,0,0)
+ sig_info (ClassOpSig _ _ _ _) = (0,1,0,0)
sig_info (SpecSig _ _ _) = (0,0,1,0)
sig_info (InlineSig _ _ _) = (0,0,0,1)
sig_info (NoInlineSig _ _ _) = (0,0,0,1)
orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
| ProtoCoreRule _ _ rule <- tidy_orphan_rules]
-lt_inst_decl (InstDecl _ _ _ dfun_id1 _) (InstDecl _ _ _ dfun_id2 _)
- = dfun_id1 < dfun_id2
- -- The dfuns are assigned names df1, df2, etc,
- -- in order of original textual
- -- occurrence, and this makes as good a sort order as any
-
-lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
+lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
+lt_inst_decl d1 d2 = instDeclName d1 < instDeclName d2
+ -- Even instance decls have names, namely the dfun name
\end{code}
(deNoteType (mkDictTy clas tys))
tidy_ty = tidyTopType forall_ty
in
- InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (toRdrName dfun_id) noSrcLoc
+ InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (toRdrName dfun_id)) noSrcLoc
\end{code}
\begin{code}
toClassOpSig (sel_id, dm_id, explicit_dm)
= ASSERT( sel_tyvars == clas_tyvars)
- ClassOpSig (toRdrName sel_id) bogus explicit_dm (toHsType op_ty) noSrcLoc
+ ClassOpSig (toRdrName sel_id) (Just (bogus, explicit_dm)) (toHsType op_ty) noSrcLoc
where
(sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
\end{code}
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.33 2000/07/06 14:08:31 simonmar Exp $
+$Id: Parser.y,v 1.34 2000/08/01 09:08:27 simonpj Exp $
Haskell grammar.
| layout_on top close { $2 }
top :: { ([RdrNameImportDecl], [RdrNameHsDecl]) }
- : importdecls ';' cvtopdecls { (reverse $1,$3) }
- | importdecls { (reverse $1,[]) }
+ : importdecls { (reverse $1,[]) }
+ | importdecls ';' cvtopdecls { (reverse $1,$3) }
| cvtopdecls { ([],$1) }
cvtopdecls :: { [RdrNameHsDecl] }
| srcloc 'class' ctype fds where
{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
- let (binds,sigs)
- = cvMonoBindsAndSigs cvClassOpSig
- (groupBindings $5)
+ let
+ (binds,sigs) = cvMonoBindsAndSigs cvClassOpSig (groupBindings $5)
in
returnP (RdrHsDecl (TyClD
(mkClassDecl cs c ts $4 sigs binds
{ let (binds,sigs)
= cvMonoBindsAndSigs cvInstDeclSig
(groupBindings $4)
- in RdrHsDecl (InstD
- (InstDecl $3 binds sigs dummyRdrVarName $1)) }
+ in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) }
| srcloc 'default' '(' types0 ')'
{ RdrHsDecl (DefD (DefaultDecl $4 $1)) }
| '[' type ']' { HsListTy $2 }
| '(' ctype ')' { $2 }
-gtycon :: { RdrName }
- : qtycon { $1 }
- | '(' ')' { unitTyCon_RDR }
- | '(' '->' ')' { funTyCon_RDR }
- | '[' ']' { listTyCon_RDR }
- | '(' commas ')' { tupleTyCon_RDR $2 }
-
-- An inst_type is what occurs in the head of an instance decl
-- e.g. (Foo a, Gaz b) => Wibble a b
-- It's kept as a single type, with a MonoDictTy at the right
| '_' { EWildPat }
| '~' aexp1 { ELazyPat $2 }
-commas :: { Int }
- : commas ',' { $1 + 1 }
- | ',' { 2 }
-
texps :: { [RdrNameHsExpr] }
: texps ',' exp { $3 : $1 }
| exp { [$1] }
-----------------------------------------------------------------------------
-- Variables, Constructors and Operators.
+gtycon :: { RdrName }
+ : qtycon { $1 }
+ | '(' ')' { unitTyCon_RDR }
+ | '(' '->' ')' { funTyCon_RDR }
+ | '[' ']' { listTyCon_RDR }
+ | '(' commas ')' { tupleTyCon_RDR $2 }
+
gcon :: { RdrName }
: '(' ')' { unitCon_RDR }
| '[' ']' { nilCon_RDR }
| 'ccall' { ccall_tyvar_RDR }
-- NOTE: no 'forall'
+commas :: { Int }
+ : commas ',' { $1 + 1 }
+ | ',' { 2 }
+
-----------------------------------------------------------------------------
{
-- superclasses both called C!)
mkClassOpSig has_default_method op ty loc
- = ClassOpSig op dm_rn has_default_method ty loc
+ = ClassOpSig op (Just (dm_rn, has_default_method)) ty loc
where
dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
cvInstDeclSig sig = sig
-cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var (panic "cvClassOpSig:dm_name")
- False
- poly_ty src_loc
+cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
cvClassOpSig sig = sig
\end{code}
{ InstDecl $3
EmptyMonoBinds {- No bindings -}
[] {- No user pragmas -}
- $5 {- Dfun id -}
+ (Just $5) {- Dfun id -}
$1
}
import RnEnv ( availName, availsToNameSet,
emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv,
warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
- lookupImplicitOccsRn, unknownNameErr,
+ lookupOrigNames, unknownNameErr,
FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV
)
import Module ( Module, ModuleName, WhereFrom(..),
= -- Initialise the renamer monad
do {
((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag)
- <- initRn mod_name us (mkSearchPath opt_HiMap) loc (rename this_mod) ;
+ <- initRn (mkThisModule mod_name) us
+ (mkSearchPath opt_HiMap) loc
+ (rename this_mod) ;
-- Check for warnings
printErrorsAndWarnings rn_errs_bag rn_warns_bag ;
\begin{code}
implicitFVs mod_name decls
- = lookupImplicitOccsRn implicit_occs `thenRn` \ implicit_names ->
+ = lookupOrigNames implicit_occs `thenRn` \ implicit_names ->
returnRn (mkNameSet (map getName default_tycons) `plusFV`
implicit_names)
where
`addOneToNameSet` cls)
`plusFV` maybe_double
where
- get (ClassOpSig n _ _ ty _)
+ get (ClassOpSig n _ ty _)
| n `elemNameSet` source_fvs = extractHsTyNames ty
| otherwise = emptyFVs
-- import This. Sigh.
-- There's really no good way to detect this, so the error message
-- in RnEnv.warnUnusedModules is weakened instead
- inst_mods = [m | InstD (InstDecl _ _ _ dfun _) <- imported_decls,
+ inst_mods = [m | InstD (InstDecl _ _ _ (Just dfun) _) <- imported_decls,
let m = moduleName (nameModule dfun),
m `elem` direct_import_mods
]
= -- First check the cache
traceRn (text "newTopBinder" <+> ppr mod <+> ppr occ) `thenRn_`
- getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
+ getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
let
- key = (moduleName mod, occ)
+ key = (moduleName mod, occ)
in
case lookupFM cache key of
new_name = setNameModule name mod
new_cache = addToFM cache key new_name
in
- setNameSupplyRn (us, inst_ns, new_cache, ipcache) `thenRn_`
+ setNameSupplyRn (us, new_cache, ipcache) `thenRn_`
traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
returnRn new_name
new_name = mkGlobalName uniq mod occ implicitImportProvenance
new_cache = addToFM cache key new_name
in
- setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_`
+ setNameSupplyRn (us', new_cache, ipcache) `thenRn_`
traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
returnRn new_name
-mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name
+newGlobalName :: ModuleName -> OccName -> RnM d Name
-- Used for *occurrences*. We make a place-holder Name, really just
-- to agree on its unique, which gets overwritten when we read in
-- the binding occurence later (newImportedBinder)
-- The place-holder Name doesn't have the right Provenance, and its
- -- Module won't have the right Package either
+ -- Module won't have the right Package either.
+ --
+ -- (We have to pass a ModuleName, not a Module, because we may be
+ -- simply looking at an occurrence M.x in an interface file.)
--
-- This means that a renamed program may have incorrect info
-- on implicitly-imported occurrences, but the correct info on the
-- it doesn't matter that we get the correct info in place till later,
-- (but since it affects DLL-ery it does matter that we get it right
-- in the end).
-mkImportedGlobalName mod_name occ
- = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
+newGlobalName mod_name occ
+ = getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
let
key = (mod_name, occ)
in
case lookupFM cache key of
- Just name -> traceRn (text "mkImportedGlobalName: hit" <+> ppr name) `thenRn_`
+ Just name -> traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_`
returnRn name
- Nothing -> setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_`
- traceRn (text "mkImportedGlobalName: new" <+> ppr name) `thenRn_`
+
+ Nothing -> setNameSupplyRn (us', new_cache, ipcache) `thenRn_`
+ traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_`
returnRn name
where
(us', us1) = splitUniqSupply us
name = mkGlobalName uniq mod occ implicitImportProvenance
new_cache = addToFM cache key name
+
+newIPName rdr_name
+ = getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
+ case lookupFM ipcache key of
+ Just name -> returnRn name
+ Nothing -> setNameSupplyRn (us', cache, new_ipcache) `thenRn_`
+ returnRn name
+ where
+ (us', us1) = splitUniqSupply us
+ uniq = uniqFromSupply us1
+ name = mkIPName uniq key
+ new_ipcache = addToFM ipcache key name
+ where key = (rdrNameOcc rdr_name)
+
updateProvenances :: [Name] -> RnM d ()
-- Update the provenances of everything that is in scope.
-- We must be careful not to disturb the Module package info
-- Step 3 must not destroy package info recorded in Step 2.
updateProvenances names
- = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
- setNameSupplyRn (us, inst_ns, foldr update cache names, ipcache)
+ = getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
+ setNameSupplyRn (us, foldr update cache names, ipcache)
where
update name cache = addToFM_C update_prov cache key name
where
update_prov name_in_cache name_with_prov
= setNameProvenance name_in_cache (getNameProvenance name_with_prov)
-
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Looking up names}
+%* *
+%*********************************************************
+
+Looking up a name in the RnEnv.
+
+\begin{code}
+lookupBndrRn rdr_name
+ = getLocalNameEnv `thenRn` \ local_env ->
+ case lookupRdrEnv local_env rdr_name of
+ Just name -> returnRn name
+ Nothing -> lookupTopBndrRn rdr_name
+
+lookupTopBndrRn rdr_name
+ = getModeRn `thenRn` \ mode ->
+ case mode of
+ InterfaceMode -> -- Look in the global name cache
+ lookupOrigName rdr_name
+
+ SourceMode -> -- Source mode, so look up a *qualified* version
+ -- of the name, so that we get the right one even
+ -- if there are many with the same occ name
+ -- There must *be* a binding
+ getModuleRn `thenRn` \ mod ->
+ getGlobalNameEnv `thenRn` \ global_env ->
+ case lookupRdrEnv global_env (qualifyRdrName (moduleName mod) rdr_name) of
+ Just (name:rest) -> ASSERT( null rest )
+ returnRn name
+ Nothing -> -- Almost always this case is a compiler bug.
+ -- But consider a type signature that doesn't have
+ -- a corresponding binder:
+ -- module M where { f :: Int->Int }
+ -- We use lookupSigOccRn, which uses lookupBndrRn (for good reasons)
+ -- and we don't want to panic. So we report an out-of-scope error
+ failWithRn (mkUnboundName rdr_name)
+ (unknownNameErr rdr_name)
+
+-- lookupSigOccRn is used for type signatures and pragmas
+-- Is this valid?
+-- module A
+-- import M( f )
+-- f :: Int -> Int
+-- f x = x
+-- It's clear that the 'f' in the signature must refer to A.f
+-- The Haskell98 report does not stipulate this, but it will!
+-- So we must treat the 'f' in the signature in the same way
+-- as the binding occurrence of 'f', using lookupBndrRn
+lookupSigOccRn :: RdrName -> RnMS Name
+lookupSigOccRn = lookupBndrRn
+
+-- lookupOccRn looks up an occurrence of a RdrName
+lookupOccRn :: RdrName -> RnMS Name
+lookupOccRn rdr_name
+ = getLocalNameEnv `thenRn` \ local_env ->
+ case lookupRdrEnv local_env rdr_name of
+ Just name -> returnRn name
+ Nothing -> lookupGlobalOccRn rdr_name
+
+-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
+-- environment. It's used only for
+-- record field names
+-- class op names in class and instance decls
+lookupGlobalOccRn rdr_name
+ = getModeRn `thenRn` \ mode ->
+ case mode of {
+ -- When processing interface files, the global env
+ -- is always empty, so go straight to the name cache
+ InterfaceMode -> lookupOrigName rdr_name ;
+
+ SourceMode ->
+
+ getGlobalNameEnv `thenRn` \ global_env ->
+ case lookupRdrEnv global_env rdr_name of
+ Just [name] -> returnRn name
+ Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff `thenRn_`
+ returnRn name
+ Nothing -> -- Not found when processing source code; so fail
+ failWithRn (mkUnboundName rdr_name)
+ (unknownNameErr rdr_name)
+ }
+\end{code}
+%
+
+@lookupOrigName@ takes an RdrName representing an {\em original}
+name, and adds it to the occurrence pool so that it'll be loaded
+later. This is used when language constructs (such as monad
+comprehensions, overloaded literals, or deriving clauses) require some
+stuff to be loaded that isn't explicitly mentioned in the code.
+
+This doesn't apply in interface mode, where everything is explicit,
+but we don't check for this case: it does no harm to record an
+``extra'' occurrence and @lookupOrigNames@ isn't used much in
+interface mode (it's only the @Nothing@ clause of @rnDerivs@ that
+calls it at all I think).
-mkImportedGlobalFromRdrName :: RdrName -> RnM d Name
-mkImportedGlobalFromRdrName rdr_name
+ \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
+
+For List and Tuple types it's important to get the correct
+@isLocallyDefined@ flag, which is used in turn when deciding
+whether there are any instance decls in this module are ``special''.
+The name cache should have the correct provenance, though.
+
+\begin{code}
+lookupOrigName :: RdrName -> RnM d Name
+lookupOrigName rdr_name
| isQual rdr_name
- = mkImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
+ = newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
| otherwise
= -- An Unqual is allowed; interface files contain
-- unqualified names for locally-defined things, such as
-- constructors of a data type.
- getModuleRn `thenRn ` \ mod_name ->
- mkImportedGlobalName mod_name (rdrNameOcc rdr_name)
-
+ getModuleRn `thenRn ` \ mod ->
+ newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
-getIPName rdr_name
- = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
- case lookupFM ipcache key of
- Just name -> returnRn name
- Nothing -> setNameSupplyRn (us', inst_ns, cache, new_ipcache) `thenRn_`
- returnRn name
- where
- (us', us1) = splitUniqSupply us
- uniq = uniqFromSupply us1
- name = mkIPName uniq key
- new_ipcache = addToFM ipcache key name
- where key = (rdrNameOcc rdr_name)
+lookupOrigNames :: [RdrName] -> RnM d NameSet
+lookupOrigNames rdr_names
+ = mapRn lookupOrigName rdr_names `thenRn` \ names ->
+ returnRn (mkNameSet names)
\end{code}
-%*********************************************************
-%* *
-\subsection{Dfuns and default methods}
-%* *
-%*********************************************************
-
-@newImplicitBinder@ is used for
- (a) dfuns (RnSource.rnDecl on InstDecls)
- (b) default methods (RnSource.rnDecl on ClassDecls)
-when these dfuns/default methods are defined in the module being compiled
+lookupSysBinder is used for the "system binders" of a type, class, or instance decl.
+It ensures that the module is set correctly in the name cache, and sets the provenance
+on the returned name too. The returned name will end up actually in the type, class,
+or instance.
\begin{code}
-newImplicitBinder occ src_loc
- = getModuleRn `thenRn` \ mod_name ->
- newTopBinder (mkThisModule mod_name) occ `thenRn` \ name ->
- returnRn (setNameProvenance name (LocalDef src_loc Exported))
+lookupSysBinder rdr_name
+ = ASSERT( isUnqual rdr_name )
+ getModuleRn `thenRn` \ mod ->
+ newTopBinder mod (rdrNameOcc rdr_name) `thenRn` \ name ->
+ getModeRn `thenRn` \ mode ->
+ case mode of
+ SourceMode -> getSrcLocRn `thenRn` \ loc ->
+ returnRn (setNameProvenance name (LocalDef loc Exported))
+ InterfaceMode -> returnRn name
\end{code}
-Make a name for the dict fun for an instance decl
+@unQualInScope@ returns a function that takes a @Name@ and tells whether
+its unqualified name is in scope. This is put as a boolean flag in
+the @Name@'s provenance to guide whether or not to print the name qualified
+in error messages.
\begin{code}
-newDFunName :: (OccName, OccName) -> SrcLoc -> RnMS Name
-newDFunName key@(cl_occ, tycon_occ) loc
- = newInstUniq string `thenRn` \ inst_uniq ->
- newImplicitBinder (mkDFunOcc string inst_uniq) loc
+unQualInScope :: GlobalRdrEnv -> Name -> Bool
+unQualInScope env
+ = lookup
where
- -- Any string that is somewhat unique will do
- string = occNameString cl_occ ++ occNameString tycon_occ
-\end{code}
-
-\begin{code}
-getDFunKey :: RenamedHsType -> (OccName, OccName) -- Used to manufacture DFun names
-getDFunKey (HsForAllTy _ _ ty) = getDFunKey ty
-getDFunKey (HsFunTy _ ty) = getDFunKey ty
-getDFunKey (HsPredTy (HsPClass cls (ty:_))) = (nameOccName cls, get_tycon_key ty)
-
-get_tycon_key (HsTyVar tv) = getOccName tv
-get_tycon_key (HsAppTy ty _) = get_tycon_key ty
-get_tycon_key (HsTupleTy (HsTupCon n _) tys) = getOccName n
-get_tycon_key (HsListTy _) = getOccName listTyCon
-get_tycon_key (HsFunTy _ _) = getOccName funTyCon
+ lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of
+ Just [name'] -> name == name'
+ other -> False
\end{code}
%*********************************************************
\begin{code}
--------------------------------------
bindLocatedLocalsRn :: SDoc -- Documentation string for error message
-> [(RdrName,SrcLoc)]
-> ([Name] -> RnMS a)
other -> returnRn ()
) `thenRn_`
- getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
+ getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
let
n = length rdr_names_w_loc
(us', us1) = splitUniqSupply us
-- Keep track of whether the name originally came from
-- an interface file.
in
- setNameSupplyRn (us', inst_ns, cache, ipcache) `thenRn_`
+ setNameSupplyRn (us', cache, ipcache) `thenRn_`
let
new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
bindCoreLocalFVRn rdr_name enclosed_scope
= getSrcLocRn `thenRn` \ loc ->
getLocalNameEnv `thenRn` \ name_env ->
- getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
+ getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
let
(us', us1) = splitUniqSupply us
uniq = uniqFromSupply us1
name = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc
in
- setNameSupplyRn (us', inst_ns, cache, ipcache) `thenRn_`
+ setNameSupplyRn (us', cache, ipcache) `thenRn_`
let
new_name_env = extendRdrEnv name_env rdr_name name
in
\end{code}
-%*********************************************************
-%* *
-\subsection{Looking up names}
-%* *
-%*********************************************************
-
-Looking up a name in the RnEnv.
-
-\begin{code}
-lookupBndrRn rdr_name
- = traceRn (text "lookupBndrRn" <+> ppr rdr_name) `thenRn_`
- getNameEnvs `thenRn` \ (global_env, local_env) ->
-
- -- Try local env
- case lookupRdrEnv local_env rdr_name of {
- Just name -> returnRn name ;
- Nothing ->
-
- getModeRn `thenRn` \ mode ->
- case mode of
- InterfaceMode -> -- Look in the global name cache
- mkImportedGlobalFromRdrName rdr_name `thenRn` \ n ->
- traceRn (text "lookupBndrRn result:" <+> ppr n) `thenRn_`
- returnRn n
-
- SourceMode -> -- Source mode, so look up a *qualified* version
- -- of the name, so that we get the right one even
- -- if there are many with the same occ name
- -- There must *be* a binding
- getModuleRn `thenRn` \ mod ->
- case lookupRdrEnv global_env (qualifyRdrName mod rdr_name) of
- Just (name:rest) -> ASSERT( null rest )
- returnRn name
- Nothing -> -- Almost always this case is a compiler bug.
- -- But consider a type signature that doesn't have
- -- a corresponding binder:
- -- module M where { f :: Int->Int }
- -- We use lookupSigOccRn, which uses lookupBndrRn (for good reasons)
- -- and we don't want to panic. So we report an out-of-scope error
- failWithRn (mkUnboundName rdr_name)
- (unknownNameErr rdr_name)
- }
-
--- lookupOccRn looks up an occurrence of a RdrName
-lookupOccRn :: RdrName -> RnMS Name
-lookupOccRn rdr_name
- = getNameEnvs `thenRn` \ (global_env, local_env) ->
- lookup_occ global_env local_env rdr_name
-
--- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
--- environment. It's used only for
--- record field names
--- class op names in class and instance decls
-lookupGlobalOccRn :: RdrName -> RnMS Name
-lookupGlobalOccRn rdr_name
- = getNameEnvs `thenRn` \ (global_env, local_env) ->
- lookup_global_occ global_env rdr_name
-
--- lookupSigOccRn is used for type signatures and pragmas
--- Is this valid?
--- module A
--- import M( f )
--- f :: Int -> Int
--- f x = x
--- It's clear that the 'f' in the signature must refer to A.f
--- The Haskell98 report does not stipulate this, but it will!
--- So we must treat the 'f' in the signature in the same way
--- as the binding occurrence of 'f', using lookupBndrRn
-lookupSigOccRn :: RdrName -> RnMS Name
-lookupSigOccRn = lookupBndrRn
-
-
--- Look in both local and global env
-lookup_occ global_env local_env rdr_name
- = case lookupRdrEnv local_env rdr_name of
- Just name -> returnRn name
- Nothing -> lookup_global_occ global_env rdr_name
-
--- Look in global env only
-lookup_global_occ global_env rdr_name
- = case lookupRdrEnv global_env rdr_name of
- Just [name] -> returnRn name
- Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff `thenRn_`
- returnRn name
- Nothing -> getModeRn `thenRn` \ mode ->
- case mode of
- -- Not found when processing source code; so fail
- SourceMode -> failWithRn (mkUnboundName rdr_name)
- (unknownNameErr rdr_name)
-
- -- Not found when processing an imported declaration,
- -- so we create a new name for the purpose
- InterfaceMode -> mkImportedGlobalFromRdrName rdr_name
-\end{code}
-%
-@lookupImplicitOccRn@ takes an RdrName representing an {\em original} name,
-and adds it to the occurrence pool so that it'll be loaded later.
-This is used when language constructs
-(such as monad comprehensions, overloaded literals, or deriving clauses)
-require some stuff to be loaded that isn't explicitly mentioned in the code.
-
-This doesn't apply in interface mode, where everything is explicit,
-but we don't check for this case:
-it does no harm to record an ``extra'' occurrence
-and @lookupImplicitOccRn@ isn't used much in interface mode
-(it's only the @Nothing@ clause of @rnDerivs@ that calls it at all I think).
-
- \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
-
-For List and Tuple types it's important to get the correct
-@isLocallyDefined@ flag, which is used in turn when deciding
-whether there are any instance decls in this module are ``special''.
-The name cache should have the correct provenance, though.
-
-\begin{code}
-lookupImplicitOccRn :: RdrName -> RnM d Name
-lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name
-
-lookupImplicitOccsRn :: [RdrName] -> RnM d NameSet
-lookupImplicitOccsRn rdr_names
- = mapRn lookupImplicitOccRn rdr_names `thenRn` \ names ->
- returnRn (mkNameSet names)
-\end{code}
-
-@unQualInScope@ returns a function that takes a @Name@ and tells whether
-its unqualified name is in scope. This is put as a boolean flag in
-the @Name@'s provenance to guide whether or not to print the name qualified
-in error messages.
-
-\begin{code}
-unQualInScope :: GlobalRdrEnv -> Name -> Bool
-unQualInScope env
- = lookup
- where
- lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of
- Just [name'] -> name == name'
- other -> False
-\end{code}
-
%************************************************************************
%* *
\subsection{Envt utility functions}
is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False
| otherwise = n1 == n2
\end{code}
+
We treat two bindings of a locally-defined name as a duplicate,
because they might be two separate, local defns and we want to report
and error for that, {\em not} eliminate a duplicate.
rnPat (LitPatIn lit)
= litOccurrence lit `thenRn` \ fvs1 ->
- lookupImplicitOccRn eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern
+ lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern
returnRn (LitPatIn lit, fvs1 `addOneFV` eq)
rnPat (LazyPatIn pat)
rnPat (NPlusKPatIn name lit)
= litOccurrence lit `thenRn` \ fvs ->
- lookupImplicitOccRn ordClass_RDR `thenRn` \ ord ->
+ lookupOrigName ordClass_RDR `thenRn` \ ord ->
lookupBndrRn name `thenRn` \ name' ->
returnRn (NPlusKPatIn name' lit, fvs `addOneFV` ord)
returnRn (HsVar name, unitFV name)
rnExpr (HsIPVar v)
- = getIPName v `thenRn` \ name ->
+ = newIPName v `thenRn` \ name ->
returnRn (HsIPVar name, emptyFVs)
-- Special case for integral literals with a large magnitude:
rnExpr (NegApp e n)
= rnExpr e `thenRn` \ (e', fv_e) ->
- lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
+ lookupOrigName negate_RDR `thenRn` \ neg ->
mkNegAppRn e' (HsVar neg) `thenRn` \ final_e ->
returnRn (final_e, fv_e `addOneFV` neg)
rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
-- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
- = lookupImplicitOccsRn [ccallableClass_RDR,
+ = lookupOrigNames [ccallableClass_RDR,
creturnableClass_RDR,
ioDataCon_RDR] `thenRn` \ implicit_fvs ->
rnExprs args `thenRn` \ (args', fvs_args) ->
rnExpr e@(HsDo do_or_lc stmts src_loc)
= pushSrcLocRn src_loc $
- lookupImplicitOccsRn implicit_rdr_names `thenRn` \ implicit_fvs ->
+ lookupOrigNames implicit_rdr_names `thenRn` \ implicit_fvs ->
rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
-- check the statement list ends in an expression
case last stmts' of {
returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
rnExpr (ArithSeqIn seq)
- = lookupImplicitOccRn enumClass_RDR `thenRn` \ enum ->
+ = lookupOrigName enumClass_RDR `thenRn` \ enum ->
rn_seq seq `thenRn` \ (new_seq, fvs) ->
returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
where
\begin{code}
rnIPBinds [] = returnRn ([], emptyFVs)
rnIPBinds ((n, expr) : binds)
- = getIPName n `thenRn` \ name ->
+ = newIPName n `thenRn` \ name ->
rnExpr expr `thenRn` \ (expr',fvExpr) ->
rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
= returnRn (unitFV (getName addrPrimTyCon))
litOccurrence (HsInt _)
- = lookupImplicitOccsRn [numClass_RDR, addr2Integer_RDR]
+ = lookupOrigNames [numClass_RDR, addr2Integer_RDR]
-- Int and Integer are forced in by Num
litOccurrence (HsFrac _)
- = lookupImplicitOccsRn [fractionalClass_RDR,ratioDataCon_RDR,addr2Integer_RDR]
+ = lookupOrigNames [fractionalClass_RDR,ratioDataCon_RDR,addr2Integer_RDR]
-- We have to make sure that the Ratio type is imported with
-- its constructor, because literals of type Ratio t are
-- built with that constructor.
= returnRn (unitFV (getName doublePrimTyCon))
litOccurrence (HsLitLit _)
- = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
+ = lookupOrigName ccallableClass_RDR `thenRn` \ cc ->
returnRn (unitFV cc)
\end{code}
\begin{code}
mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
mkAssertExpr =
- mkImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name ->
- getSrcLocRn `thenRn` \ sloc ->
+ lookupOrigName assertErr_RDR `thenRn` \ name ->
+ getSrcLocRn `thenRn` \ sloc ->
-- if we're ignoring asserts, return (\ _ e -> e)
-- if not, return (assertError "src-loc")
-- If we do loadExport first the wrong info gets into the cache (unless we
-- explicitly tag each export which seems a bit of a bore)
- getModuleRn `thenRn` \ this_mod_nm ->
+ getModuleRn `thenRn` \ this_mod ->
let
- mod = pi_mod iface
+ mod = pi_mod iface
in
-- Sanity check. If we're system-importing a module we know nothing at all
-- about, it should be from a different package to this one
case from of { ImportBySystem -> True; other -> False } &&
isLocalModule mod,
ppr mod )
- foldlRn (loadDecl mod) (iDecls ifaces) (pi_decls iface) `thenRn` \ new_decls ->
- foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts ->
- loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ new_rules ->
- loadFixDecls mod_name (iFixes ifaces) (pi_fixity iface) `thenRn` \ new_fixities ->
- foldlRn (loadDeprec mod) (iDeprecs ifaces) (pi_deprecs iface) `thenRn` \ new_deprecs ->
- mapRn (loadExport this_mod_nm) (pi_exports iface) `thenRn` \ avails_s ->
+ foldlRn (loadDecl mod) (iDecls ifaces) (pi_decls iface) `thenRn` \ new_decls ->
+ foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts ->
+ loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ new_rules ->
+ loadFixDecls mod_name (iFixes ifaces) (pi_fixity iface) `thenRn` \ new_fixities ->
+ foldlRn (loadDeprec mod) (iDeprecs ifaces) (pi_deprecs iface) `thenRn` \ new_deprecs ->
+ mapRn (loadExport this_mod) (pi_exports iface) `thenRn` \ avails_s ->
let
-- For an explicit user import, add to mod_map info about
-- the things the imported module depends on, extracted
-- Loading the export list
-----------------------------------------------------
-loadExport :: ModuleName -> ExportItem -> RnM d [AvailInfo]
+loadExport :: Module -> ExportItem -> RnM d [AvailInfo]
loadExport this_mod (mod, entities)
- | mod == this_mod = returnRn []
+ | mod == moduleName this_mod = returnRn []
-- If the module exports anything defined in this module, just ignore it.
-- Reason: otherwise it looks as if there are two local definition sites
-- for the thing, and an error gets reported. Easiest thing is just to
| otherwise
= mapRn (load_entity mod) entities
where
- new_name mod occ = mkImportedGlobalName mod occ
+ new_name mod occ = newGlobalName mod occ
load_entity mod (Avail occ)
= new_name mod occ `thenRn` \ name ->
returnRn (extendNameEnvList fixity_env to_add)
loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc)
- = mkImportedGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name ->
+ = newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name ->
returnRn (name, FixitySig name fixity loc)
munged_inst_ty = removeContext inst_ty
free_names = extractHsTyRdrNames munged_inst_ty
in
- setModuleRn (moduleName mod) $
- mapRn mkImportedGlobalFromRdrName free_names `thenRn` \ gate_names ->
+ setModuleRn mod $
+ mapRn lookupOrigName free_names `thenRn` \ gate_names ->
returnRn ((mkNameSet gate_names, (mod, InstD decl)) `consBag` insts)
| null rules || opt_IgnoreIfacePragmas
= returnRn rule_bag
| otherwise
- = setModuleRn mod_name $
+ = setModuleRn mod $
mapRn (loadRule mod) rules `thenRn` \ new_rules ->
returnRn (rule_bag `unionBags` listToBag new_rules)
- where
- mod_name = moduleName mod
loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl
-- "Gate" the rule simply by whether the rule variable is
-- needed. We can refine this later.
loadRule mod decl@(IfaceRule _ _ var _ _ src_loc)
- = mkImportedGlobalFromRdrName var `thenRn` \ var_name ->
+ = lookupOrigName var `thenRn` \ var_name ->
returnRn (unitNameSet var_name, (mod, RuleD decl))
loadBuiltinRules :: [(RdrName, CoreRule)] -> RnMG ()
setIfacesRn (ifaces { iRules = iRules ifaces `unionBags` listToBag rule_decls })
loadBuiltinRule (var, rule)
- = mkImportedGlobalFromRdrName var `thenRn` \ var_name ->
+ = lookupOrigName var `thenRn` \ var_name ->
returnRn (unitNameSet var_name, (nameModule var_name, RuleD (IfaceRuleOut var rule)))
returnRn deprec_env
loadDeprec mod deprec_env (Deprecation ie txt _)
- = setModuleRn (moduleName mod) $
- mapRn mkImportedGlobalFromRdrName (ieNames ie) `thenRn` \ names ->
+ = setModuleRn mod $
+ mapRn lookupOrigName (ieNames ie) `thenRn` \ names ->
traceRn (text "loaded deprecation(s) for" <+> hcat (punctuate comma (map ppr names)) <> colon <+> ppr txt) `thenRn_`
returnRn (extendNameEnvList deprec_env (zip names (repeat txt)))
\end{code}
= returnRn upToDate -- Yes! All up to date!
checkEntityUsage mod decls ((occ_name,old_vers) : rest)
- = mkImportedGlobalName mod occ_name `thenRn` \ name ->
+ = newGlobalName mod occ_name `thenRn` \ name ->
case lookupNameEnv decls name of
Nothing -> -- We used it before, but it ain't there now
= new_name nm loc `thenRn` \ name ->
returnRn (Just (Avail name))
- | otherwise -- a foreign export
- = lookupImplicitOccRn nm `thenRn_`
+ | otherwise -- a foreign export
+ = lookupOrigName nm `thenRn_`
returnRn Nothing
getDeclBinders new_name (DefD _) = returnRn Nothing
getConFieldNames new_name [] = returnRn []
-getClassOpNames new_name (ClassOpSig op _ _ _ src_loc) = new_name op src_loc
+getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
\end{code}
@getDeclSysBinders@ gets the implicit binders introduced by a decl.
-- Common part
data RnDown = RnDown {
- rn_mod :: ModuleName,
+ rn_mod :: Module,
rn_loc :: SrcLoc,
rn_ns :: IORef RnNameSupply,
rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg),
type RnNameSupply
= ( UniqSupply
- , FiniteMap String Int
- -- This is used as a name supply for dictionary functions
- -- From the inst decl we derive a string, usually by glomming together
- -- the class and tycon name -- but it doesn't matter exactly how;
- -- this map then gives a unique int for each inst decl with that
- -- string. (In Haskell 98 there can only be one,
- -- but not so in more extended versions; also class CC type T
- -- and class C type TT might both give the string CCT
- --
- -- We could just use one Int for all the instance decls, but this
- -- way the uniques change less when you add an instance decl,
- -- hence less recompilation
-
, FiniteMap (ModuleName, OccName) Name
-- Ensures that one (module,occname) pair gets one unique
, FiniteMap OccName Name
%************************************************************************
\begin{code}
-initRn :: ModuleName -> UniqSupply -> SearchPath -> SrcLoc
+initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc
-> RnMG r
-> IO (r, Bag ErrMsg, Bag WarnMsg)
initRn mod us dirs loc do_rn = do
himaps <- mkModuleHiMaps dirs
- names_var <- newIORef (us, emptyFM, builtins, emptyFM)
+ names_var <- newIORef (us, builtins, emptyFM)
errs_var <- newIORef (emptyBag,emptyBag)
iface_var <- newIORef emptyIfaces
let
initIfaceRnMS :: Module -> RnMS r -> RnM d r
initIfaceRnMS mod thing_inside
= initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $
- setModuleRn (moduleName mod) thing_inside
+ setModuleRn mod thing_inside
emptyIfaces :: Ifaces
emptyIfaces = Ifaces { iImpModInfo = emptyFM,
once you must either split it, or install a fresh unique supply.
\begin{code}
-renameSourceCode :: ModuleName
+renameSourceCode :: Module
-> RnNameSupply
-> RnMS r
-> r
-renameSourceCode mod_name name_supply m
+renameSourceCode mod name_supply m
= unsafePerformIO (
-- It's not really unsafe! When renaming source code we
-- only do any I/O if we need to read in a fixity declaration;
let
rn_down = RnDown { rn_loc = mkGeneratedSrcLoc, rn_ns = names_var,
rn_errs = errs_var, rn_hi_maps = himaps,
- rn_mod = mod_name,
+ rn_mod = mod,
rn_ifaces = panic "rnameSourceCode: rn_ifaces" -- Not required
}
s_down = SDown { rn_mode = InterfaceMode,
setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down
= writeIORef names_var names'
--- See comments with RnNameSupply above.
-newInstUniq :: String -> RnM d Int
-newInstUniq key (RnDown {rn_ns = names_var}) l_down
- = readIORef names_var >>= \ (us, mapInst, cache, ipcache) ->
- let
- uniq = case lookupFM mapInst key of
- Just x -> x+1
- Nothing -> 0
- mapInst' = addToFM mapInst key uniq
- in
- writeIORef names_var (us, mapInst', cache, ipcache) >>
- return uniq
-
getUniqRn :: RnM d Unique
getUniqRn (RnDown {rn_ns = names_var}) l_down
- = readIORef names_var >>= \ (us, mapInst, cache, ipcache) ->
+ = readIORef names_var >>= \ (us, cache, ipcache) ->
let
(us1,us') = splitUniqSupply us
in
- writeIORef names_var (us', mapInst, cache, ipcache) >>
+ writeIORef names_var (us', cache, ipcache) >>
return (uniqFromSupply us1)
\end{code}
%=====================
\begin{code}
-getModuleRn :: RnM d ModuleName
-getModuleRn (RnDown {rn_mod = mod_name}) l_down
- = return mod_name
+getModuleRn :: RnM d Module
+getModuleRn (RnDown {rn_mod = mod}) l_down
+ = return mod
-setModuleRn :: ModuleName -> RnM d a -> RnM d a
+setModuleRn :: Module -> RnM d a -> RnM d a
setModuleRn new_mod enclosed_thing rn_down l_down
= enclosed_thing (rn_down {rn_mod = new_mod}) l_down
\end{code}
getLocalNameEnv rn_down (SDown {rn_lenv = local_env})
= return local_env
+getGlobalNameEnv :: RnMS GlobalRdrEnv
+getGlobalNameEnv rn_down (SDown {rn_genv = global_env})
+ = return global_env
+
setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a
setLocalNameEnv local_env' m rn_down l_down
= m rn_down (l_down {rn_lenv = local_env'})
rec_exp_fn :: Name -> ExportFlag
rec_exp_fn = mk_export_fn (availsToNameSet rec_export_avails)
in
- setModuleRn this_mod $
-- PROCESS LOCAL DECLS
-- Do these *first* so that the correct provenance gets
\begin{code}
importsFromLocalDecls mod_name rec_exp_fn decls
- = mapRn (getLocalDeclBinders newLocalName) decls `thenRn` \ avails_s ->
+ = mapRn (getLocalDeclBinders mod rec_exp_fn) decls `thenRn` \ avails_s ->
let
avails = concat avails_s
where
mod = mkThisModule mod_name
- newLocalName rdr_name loc
- = check_unqual rdr_name loc `thenRn_`
- newTopBinder mod (rdrNameOcc rdr_name) `thenRn` \ name ->
- returnRn (setNameProvenance name (LocalDef loc (rec_exp_fn name)))
-
- -- There should never be a qualified name in a binding position (except in instance decls)
- -- The parser doesn't check this because the same parser parses instance decls
- check_unqual rdr_name loc
- | isUnqual rdr_name = returnRn ()
- | otherwise = qualNameErr (text "the binding for" <+> quotes (ppr rdr_name))
- (rdr_name,loc)
-
-getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function
- -> RdrNameHsDecl
- -> RnMG Avails
-getLocalDeclBinders new_name (ValD binds)
+getLocalDeclBinders :: Module -> (Name -> ExportFlag)
+ -> RdrNameHsDecl -> RnMG Avails
+getLocalDeclBinders mod rec_exp_fn (ValD binds)
= mapRn do_one (bagToList (collectTopBinders binds))
where
- do_one (rdr_name, loc) = new_name rdr_name loc `thenRn` \ name ->
+ do_one (rdr_name, loc) = newLocalName mod rec_exp_fn rdr_name loc `thenRn` \ name ->
returnRn (Avail name)
-getLocalDeclBinders new_name decl
- = getDeclBinders new_name decl `thenRn` \ maybe_avail ->
+getLocalDeclBinders mod rec_exp_fn decl
+ = getDeclBinders (newLocalName mod rec_exp_fn) decl `thenRn` \ maybe_avail ->
case maybe_avail of
Nothing -> returnRn [] -- Instance decls and suchlike
- Just avail -> getDeclSysBinders new_sys_name decl `thenRn_`
- returnRn [avail]
+ Just avail -> returnRn [avail]
+
+newLocalName mod rec_exp_fn rdr_name loc
+ = check_unqual rdr_name loc `thenRn_`
+ newTopBinder mod (rdrNameOcc rdr_name) `thenRn` \ name ->
+ returnRn (setNameProvenance name (LocalDef loc (rec_exp_fn name)))
where
- -- The getDeclSysBinders is just to get the names of superclass selectors
- -- etc, into the cache
- new_sys_name rdr_name loc = newImplicitBinder (rdrNameOcc rdr_name) loc
+ -- There should never be a qualified name in a binding position (except in instance decls)
+ -- The parser doesn't check this because the same parser parses instance decls
+ check_unqual rdr_name loc
+ | isUnqual rdr_name = returnRn ()
+ | otherwise = qualNameErr (text "the binding for" <+> quotes (ppr rdr_name))
+ (rdr_name,loc)
\end{code}
+
%************************************************************************
%* *
\subsection{Filtering imports}
import HsCore
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
-import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName,
- lookupImplicitOccRn, lookupImplicitOccsRn,
+import RnEnv ( bindTyVarsRn, lookupTopBndrRn, lookupOccRn, newIPName,
+ lookupOrigName, lookupOrigNames, lookupSysBinder,
bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn,
bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
bindCoreLocalFVRn, bindCoreLocalsFVRn, bindLocalNames,
checkDupOrQualNames, checkDupNames,
- mkImportedGlobalName, mkImportedGlobalFromRdrName,
- newDFunName, getDFunKey, newImplicitBinder,
FreeVars, emptyFVs, plusFV, plusFVs, unitFV,
addOneFV, mapFvRn
)
rnDecl (SigD (IfaceSig name ty id_infos loc))
= pushSrcLocRn loc $
- mkImportedGlobalFromRdrName name `thenRn` \ name' ->
+ lookupTopBndrRn name `thenRn` \ name' ->
rnHsType doc_str ty `thenRn` \ (ty',fvs1) ->
mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) ->
returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
\begin{code}
rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings pragmas src_loc))
= pushSrcLocRn src_loc $
- lookupBndrRn tycon `thenRn` \ tycon' ->
+ lookupTopBndrRn tycon `thenRn` \ tycon' ->
bindTyVarsFVRn data_doc tyvars $ \ tyvars' ->
rnContext data_doc context `thenRn` \ (context', cxt_fvs) ->
checkDupOrQualNames data_doc con_names `thenRn_`
rnDecl (TyClD (TySynonym name tyvars ty src_loc))
= pushSrcLocRn src_loc $
- lookupBndrRn name `thenRn` \ name' ->
+ lookupTopBndrRn name `thenRn` \ name' ->
bindTyVarsFVRn syn_doc tyvars $ \ tyvars' ->
rnHsType syn_doc (unquantify ty) `thenRn` \ (ty', ty_fvs) ->
returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
tname dname dwname snames src_loc))
= pushSrcLocRn src_loc $
- lookupBndrRn cname `thenRn` \ cname' ->
+ lookupTopBndrRn cname `thenRn` \ cname' ->
-- Deal with the implicit tycon and datacon name
-- They aren't in scope (because they aren't visible to the user)
-- So the 'Imported' part of this call is not relevant.
-- Unclean; but since these two are the only place this happens
-- I can't work up the energy to do it more beautifully
- mkImportedGlobalFromRdrName tname `thenRn` \ tname' ->
- mkImportedGlobalFromRdrName dname `thenRn` \ dname' ->
- mkImportedGlobalFromRdrName dwname `thenRn` \ dwname' ->
- mapRn mkImportedGlobalFromRdrName snames `thenRn` \ snames' ->
+ lookupSysBinder tname `thenRn` \ tname' ->
+ lookupSysBinder dname `thenRn` \ dname' ->
+ lookupSysBinder dwname `thenRn` \ dwname' ->
+ mapRn lookupSysBinder snames `thenRn` \ snames' ->
-- Tyvars scope over bindings and context
bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' ->
checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs `thenRn` \ (sigs', sig_fvs) ->
let
- binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ]
+ binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
in
renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ (non_ops', fix_fvs) ->
-- Check the methods
checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
- rnMethodBinds mbinds
- `thenRn` \ (mbinds', meth_fvs) ->
+ rnMethodBinds mbinds `thenRn` \ (mbinds', meth_fvs) ->
-- Typechecker is responsible for checking that we only
-- give default-method bindings for things in this class.
sig_doc = text "the signatures for class" <+> ppr cname
meth_doc = text "the default-methods for class" <+> ppr cname
- sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ _ locn <- sigs]
+ sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
- meth_rdr_names = map fst meth_rdr_names_w_locs
- rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op dm_rdr_name explicit_dm ty locn)
+ rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn)
= pushSrcLocRn locn $
- lookupBndrRn op `thenRn` \ op_name ->
+ lookupTopBndrRn op `thenRn` \ op_name ->
-- Check the signature
rnHsSigType (quotes (ppr op)) ty `thenRn` \ (new_ty, op_ty_fvs) ->
mapRn_ check_in_op_ty clas_tyvars `thenRn_`
-- Make the default-method name
- getModeRn `thenRn` \ mode ->
- (case mode of
- SourceMode -> -- Source class decl
- newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn `thenRn` \ dm_name ->
- returnRn (dm_name, op `elem` meth_rdr_names, emptyFVs)
+ (case maybe_dm_stuff of
+ Nothing -> returnRn (Nothing, emptyFVs) -- Source-file class decl
- InterfaceMode
+ Just (dm_rdr_name, explicit_dm)
-> -- Imported class that has a default method decl
-- See comments with tname, snames, above
- lookupImplicitOccRn dm_rdr_name `thenRn` \ dm_name ->
- returnRn (dm_name, explicit_dm, if explicit_dm then unitFV dm_name else emptyFVs)
+ lookupSysBinder dm_rdr_name `thenRn` \ dm_name ->
+ returnRn (Just (dm_name, explicit_dm),
+ if explicit_dm then unitFV dm_name else emptyFVs)
-- An imported class decl for a class decl that had an explicit default
-- method, mentions, rather than defines,
-- the default method, so we must arrange to pull it in
- ) `thenRn` \ (dm_name, final_explicit_dm, dm_fvs) ->
+ ) `thenRn` \ (maybe_dm_stuff', dm_fvs) ->
- returnRn (ClassOpSig op_name dm_name final_explicit_dm new_ty locn, op_ty_fvs `plusFV` dm_fvs)
+ returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn, op_ty_fvs `plusFV` dm_fvs)
\end{code}
%*********************************************************
\begin{code}
-rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
+rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc))
= pushSrcLocRn src_loc $
rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
let
renameSigs (okInstDclSig binder_set) uprags
) `thenRn` \ (new_uprags, prag_fvs) ->
- getModeRn `thenRn` \ mode ->
- (case mode of
- InterfaceMode -> lookupImplicitOccRn dfun_rdr_name `thenRn` \ dfun_name ->
- returnRn (dfun_name, unitFV dfun_name)
- SourceMode -> newDFunName (getDFunKey inst_ty') src_loc
- `thenRn` \ dfun_name ->
- returnRn (dfun_name, emptyFVs)
- )
- `thenRn` \ (dfun_name, dfun_fv) ->
+ (case maybe_dfun_rdr_name of
+ Nothing -> returnRn (Nothing, emptyFVs)
+
+ Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name `thenRn` \ dfun_name ->
+ returnRn (Just dfun_name, unitFV dfun_name)
+ ) `thenRn` \ (maybe_dfun_name, dfun_fv) ->
-- The typechecker checks that all the bindings are for the right class.
- returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc),
+ returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc),
inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv)
where
meth_doc = text "the bindings in an instance declaration"
lookupOccRn name `thenRn` \ name' ->
let
extra_fvs FoExport
- | isDyn =
- lookupImplicitOccsRn [makeStablePtr_RDR, deRefStablePtr_RDR,
- bindIO_RDR, returnIO_RDR]
- | otherwise =
- lookupImplicitOccsRn [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
+ | isDyn = lookupOrigNames [makeStablePtr_RDR, deRefStablePtr_RDR,
+ bindIO_RDR, returnIO_RDR]
+ | otherwise =
+ lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
returnRn (addOneFV fvs name')
extra_fvs other = returnRn emptyFVs
in
rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars)
rnConDecl (ConDecl name wkr tvs cxt details locn)
= pushSrcLocRn locn $
- checkConName name `thenRn_`
- lookupBndrRn name `thenRn` \ new_name ->
+ checkConName name `thenRn_`
+ lookupTopBndrRn name `thenRn` \ new_name ->
- mkImportedGlobalFromRdrName wkr `thenRn` \ new_wkr ->
+ lookupSysBinder wkr `thenRn` \ new_wkr ->
-- See comments with ClassDecl
bindTyVarsFVRn doc tvs $ \ new_tyvars ->
where
rn_field Nothing = returnRn Nothing
rn_field (Just f) =
- lookupBndrRn f `thenRn` \ new_f ->
+ lookupTopBndrRn f `thenRn` \ new_f ->
returnRn (Just new_f)
rnConDetails doc locn (RecCon fields)
field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
rnField doc (names, ty)
- = mapRn lookupBndrRn names `thenRn` \ new_names ->
+ = mapRn lookupTopBndrRn names `thenRn` \ new_names ->
rnBangTy doc ty `thenRn` \ (new_ty, fvs) ->
returnRn ((new_names, new_ty), fvs)
returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
rnPred doc (HsPIParam n ty)
- = getIPName n `thenRn` \ name ->
+ = newIPName n `thenRn` \ name ->
rnHsType doc ty `thenRn` \ (ty', fvs) ->
returnRn (HsPIParam name ty', fvs)
\end{code}
import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr )
import DataCon ( isUnboxedTupleCon )
import Type ( splitTyConApp_maybe )
+import Subst ( InScopeSet, uniqAway, emptyInScopeSet, extendInScopeSet, elemInScopeSet )
import CoreSyn
import VarEnv
import CoreLint ( beginPass, endPass )
y2 = C y1 b
will get transformed to C x1 b, and then to x2.
-So we carry an extra var->var mapping which we apply *before* looking up in the
+So we carry an extra var->var substitution which we apply *before* looking up in the
reverse mapping.
IMPORTANT NOTE
~~~~~~~~~~~~~~
-This pass relies on the no-shadowing invariant, so it must run
-immediately after the simplifier.
-
+We have to be careful about shadowing.
For example, consider
f = \x -> let y = x+x in
h = \x -> x+x
in ...
-Here we must *not* do CSE on the inner x+x!
+Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no
+shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
+We can simply add clones to the substitution already described.
+
+However, we do NOT clone type variables. It's just too hard, because then we need
+to run the substitution over types and IdInfo. No no no. Instead, we just throw
+away the entire reverse mapping if this unusual situation ever shows up.
+(In fact, I think the simplifier does guarantee no-shadowing for type variables.)
Another important wrinkle
but for CSE purpose that's a bad idea.
So we add the binding (wild1 -> a) to the extra var->var mapping.
-
+Notice this is exactly backwards to what the simplifier does, which is
+to try to replaces uses of a with uses of wild1
Yet another wrinkle
~~~~~~~~~~~~~~~~~~~
We'd like to replace (h x) in the alternative, by y. But because of
the preceding "Another important wrinkle", we only want to add the mapping
scrutinee -> case binder
-to the CSE mapping if the scrutinee is a non-trivial expression.
+to the reverse CSE mapping if the scrutinee is a non-trivial expression.
+(If the scrutinee is a simple variable we want to add the mapping
+ case binder -> scrutinee
+to the substitution
%************************************************************************
do_one env (id, rhs) = case lookupCSEnv env rhs' of
- Just other_id -> (extendSubst env id other_id, (id, Var other_id))
- Nothing -> (addCSEnvItem env id rhs', (id, rhs'))
+ Just other_id -> (extendSubst env' id other_id, (id', Var other_id))
+ Nothing -> (addCSEnvItem env' id' rhs', (id', rhs'))
where
- rhs' = cseExpr env rhs
-
+ (env', id') = addBinder env id
+ rhs' = cseExpr env' rhs
tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
tryForCSE env (Type t) = Type t
cseExpr env (Var v) = Var (lookupSubst env v)
cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
cseExpr env (Note n e) = Note n (cseExpr env e)
-cseExpr env (Lam b e) = Lam b (cseExpr env e)
-cseExpr env (Let bind e) = let (env1, bind') = cseBind env bind
- in Let bind' (cseExpr env1 e)
-cseExpr env (Case scrut bndr alts) = Case scrut' bndr (cseAlts env scrut' bndr alts)
+cseExpr env (Lam b e) = let (env', b') = addBinder env b
+ in Lam b' (cseExpr env' e)
+cseExpr env (Let bind e) = let (env', bind') = cseBind env bind
+ in Let bind' (cseExpr env' e)
+cseExpr env (Case scrut bndr alts) = Case scrut' bndr' (cseAlts env' scrut' bndr bndr' alts)
where
scrut' = tryForCSE env scrut
+ (env', bndr') = addBinder env bndr
-cseAlts env new_scrut bndr alts
+cseAlts env scrut' bndr bndr' alts
= map cse_alt alts
where
(con_target, alt_env)
- = case new_scrut of
- Var v -> (v, extendSubst env bndr v) -- See "another important wrinkle"
- -- map: bndr -> v
+ = case scrut' of
+ Var v' -> (v', extendSubst env bndr v') -- See "another important wrinkle"
+ -- map: bndr -> v'
- other -> (bndr, extendCSEnv env bndr new_scrut) -- See "yet another wrinkle"
- -- map: new_scrut -> bndr
+ other -> (bndr', extendCSEnv env bndr' scrut') -- See "yet another wrinkle"
+ -- map: scrut' -> bndr'
arg_tys = case splitTyConApp_maybe (idType bndr) of
Just (_, arg_tys) -> arg_tys
-- Don't replace True by x!
-- Hence the 'null args', which also deal with literals and DEFAULT
-- And we can't CSE on unboxed tuples
- = (DataAlt con, args, tryForCSE new_env rhs)
+ = (DataAlt con, args', tryForCSE new_env rhs)
where
- new_env = extendCSEnv alt_env con_target (mkAltExpr (DataAlt con) args arg_tys)
+ (env', args') = addBinders alt_env args
+ new_env = extendCSEnv env' con_target (mkAltExpr (DataAlt con) args' arg_tys)
cse_alt (con, args, rhs)
- = (con, args, tryForCSE alt_env rhs)
+ = (con, args', tryForCSE env' rhs)
+ where
+ (env', args') = addBinders alt_env args
\end{code}
%************************************************************************
\begin{code}
-data CSEnv = CS (UniqFM [(Id, CoreExpr)]) -- The expr in the range has already been CSE'd
- (IdEnv Id) -- Simple substitution
+data CSEnv = CS CSEMap InScopeSet (IdEnv Id)
+ -- Simple substitution
+
+type CSEMap = UniqFM [(Id, CoreExpr)] -- This is the reverse mapping
+ -- It maps the hash-code of an expression to list of (x,e) pairs
+ -- This means that it's good to replace e by x
+ -- INVARIANT: The expr in the range has already been CSE'd
-emptyCSEnv = CS emptyUFM emptyVarEnv
+emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv
lookupCSEnv :: CSEnv -> CoreExpr -> Maybe Id
-lookupCSEnv (CS cs _) expr
+lookupCSEnv (CS cs _ _) expr
= case lookupUFM cs (hashExpr expr) of
Nothing -> Nothing
Just pairs -> lookup_list pairs expr
addCSEnvItem env id expr | exprIsBig expr = env
| otherwise = extendCSEnv env id expr
-extendCSEnv (CS cs sub) id expr
- = CS (addToUFM_C combine cs hash [(id, expr)]) sub
+extendCSEnv (CS cs in_scope sub) id expr
+ = CS (addToUFM_C combine cs hash [(id, expr)]) in_scope sub
where
hash = hashExpr expr
combine old new = WARN( length result > 4, text "extendCSEnv: long list:" <+> ppr result )
where
result = new ++ old
-lookupSubst (CS _ sub) x = case lookupVarEnv sub x of
- Just y -> y
- Nothing -> x
+lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
+ Just y -> y
+ Nothing -> x
+
+extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y)
+
+addBinder :: CSEnv -> Id -> (CSEnv, Id)
+addBinder env@(CS cs in_scope sub) v
+ | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
+ | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
+ | not (isId v) = WARN( True, ppr v )
+ (CS emptyUFM in_scope sub, v)
+ -- This last case is the unusual situation where we have shadowing of
+ -- a type variable; we have to discard the CSE mapping
+ -- See "IMPORTANT NOTE" at the top
+ where
+ v' = uniqAway in_scope v
-extendSubst (CS cs sub) x y = CS cs (extendVarEnv sub x y)
+addBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
+addBinders env vs = mapAccumL addBinder env vs
\end{code}
exp = <expression>
...
-Without this we never get rid of the exp = loc thing.
-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 it's tidier to do it here.
-
+Without this we never get rid of the exp = loc thing. 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 it's tidier to do it here.
If more than one exported thing is equal to a local thing (i.e., the
local thing really is shared), then we do one only:
go :: OccEnv -> [CoreBind]
-> (UsageDetails, -- Occurrence info
IdEnv Id, -- Indirection elimination info
- [CoreBind])
+ -- Maps local-id -> exported-id, but it embodies
+ -- bindings of the form exported-id = local-id in
+ -- the argument to go
+ [CoreBind]) -- Occ-analysed bindings, less the exported-id=local-id ones
go env [] = (emptyDetails, emptyVarEnv, [])
score :: Node Details2 -> Int -- Higher score => less likely to be picked as loop breaker
score ((bndr, rhs), _, _)
- | exprIsTrivial rhs &&
- 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
+ | exprIsTrivial rhs = 4 -- Practically certain to be inlined
+ -- Used to have also: && not (isExportedId bndr)
+ -- But I found this sometimes cost an extra iteration when we have
+ -- rec { d = (a,b); a = ...df...; b = ...df...; df = d }
+ -- where df is the exported dictionary. Then df makes a really
+ -- bad choice for loop breaker
+
+ | not_fun_ty (idType bndr) = 3 -- Data types help with cases
+ -- This used to have a lower score than inlineCandidate, but
+ -- it's *really* helpful if dictionaries get inlined fast,
+ -- so I'm experimenting with giving higher priority to data-typed things
+
+ | inlineCandidate bndr rhs = 2 -- Likely to be inlined
+
| not (isEmptyCoreRules (idSpecialisation bndr)) = 1
-- Avoid things with specialisations; we'd like
-- to take advantage of them in the subsequent bindings
+
| otherwise = 0
inlineCandidate :: Id -> CoreExpr -> Bool
3. 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.)
+ but the latter now only ensures that there's no shadowing; indeed, even
+ that may not be true.)
+
+ NOTE: this can't be done using the uniqAway idea, because the variable
+ must be unique in the whole program, not just its current scope,
+ because two variables in different scopes may float out to the
+ same top level place
+
NOTE: Very tiresomely, we must apply this substitution to
the rules stored inside a variable too.
\begin{code}
lvlLamBndrs :: Level -> [CoreBndr] -> (Level, [(CoreBndr, Level)])
-- Compute the levels for the binders of a lambda group
+-- The binders returned are exactly the same as the ones passed,
+-- but they are now paired with a level
lvlLamBndrs lvl []
= (lvl, [])
\begin{code}
type LevelEnv = (Bool, -- True <=> Float lambdas too
VarEnv Level, -- Domain is *post-cloned* TyVars and Ids
- SubstEnv, -- Domain is pre-cloned Ids
+ Subst, -- Domain is pre-cloned Ids; tracks the in-scope set
+ -- so that subtitution is capture-avoiding
IdEnv ([Var], LevelledExpr)) -- Domain is pre-cloned Ids
-- We clone let-bound variables so that they are still
-- distinct when floated out; hence the SubstEnv/IdEnv.
-- We also use these envs when making a variable polymorphic
-- because we want to float it out past a big lambda.
--
- -- The two Envs always implement the same mapping, but the
+ -- The SubstEnv and IdEnv always implement the same mapping, but the
-- SubstEnv maps to CoreExpr and the IdEnv to LevelledExpr
-- Since the range is always a variable or type application,
-- there is never any difference between the two, but sadly
-- The domain of the VarEnv Level is the *post-cloned* Ids
initialEnv :: Bool -> LevelEnv
-initialEnv float_lams = (float_lams, emptyVarEnv, emptySubstEnv, emptyVarEnv)
+initialEnv float_lams = (float_lams, emptyVarEnv, emptySubst, emptyVarEnv)
floatLams :: LevelEnv -> Bool
floatLams (float_lams, _, _, _) = float_lams
extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv
-- Used when *not* cloning
-extendLvlEnv (float_lams, lvl_env, subst_env, id_env) prs
+extendLvlEnv (float_lams, lvl_env, subst, id_env) prs
= (float_lams,
foldl add_lvl lvl_env prs,
- foldl del_subst subst_env prs,
+ foldl del_subst subst prs,
foldl del_id id_env prs)
where
add_lvl env (v,l) = extendVarEnv env v l
- del_subst env (v,_) = delSubstEnv env v
+ del_subst env (v,_) = extendInScope env v
del_id env (v,_) = delVarEnv env v
-- We must remove any clone for this variable name in case of
- -- shadowing. This bit me in the following case (in
- -- nofib/real/gg/Spark.hs):
+ -- shadowing. This bit me in the following case
+ -- (in nofib/real/gg/Spark.hs):
--
-- case ds of wild {
-- ... -> case e of wild {
Var v -> extendCloneLvlEnv lvl env [(case_bndr, v)]
other -> extendLvlEnv env [(case_bndr,lvl)]
-extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst_env, id_env) abs_vars bndr_pairs
+extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst, id_env) abs_vars bndr_pairs
= (float_lams,
- foldl add_lvl lvl_env bndr_pairs,
- foldl add_subst subst_env bndr_pairs,
- foldl add_id id_env bndr_pairs)
+ foldl add_lvl lvl_env bndr_pairs,
+ foldl add_subst subst bndr_pairs,
+ foldl add_id id_env bndr_pairs)
where
- add_lvl env (v,v') = extendVarEnv env v' dest_lvl
- add_subst env (v,v') = extendSubstEnv env v (DoneEx (mkVarApps (Var v') abs_vars))
- add_id env (v,v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)
+ add_lvl env (v,v') = extendVarEnv env v' dest_lvl
+ add_subst env (v,v') = extendSubst env v (DoneEx (mkVarApps (Var v') abs_vars))
+ add_id env (v,v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)
-extendCloneLvlEnv lvl (float_lams, lvl_env, subst_env, id_env) bndr_pairs
+extendCloneLvlEnv lvl (float_lams, lvl_env, subst, id_env) bndr_pairs
= (float_lams,
- foldl add_lvl lvl_env bndr_pairs,
- foldl add_subst subst_env bndr_pairs,
- foldl add_id id_env bndr_pairs)
+ foldl add_lvl lvl_env bndr_pairs,
+ foldl add_subst subst bndr_pairs,
+ foldl add_id id_env bndr_pairs)
where
- add_lvl env (v,v') = extendVarEnv env v' lvl
- add_subst env (v,v') = extendSubstEnv env v (DoneEx (Var v'))
- add_id env (v,v') = extendVarEnv env v ([v'], Var v')
+ add_lvl env (v,v') = extendVarEnv env v' lvl
+ add_subst env (v,v') = extendSubst env v (DoneEx (Var v'))
+ add_id env (v,v') = extendVarEnv env v ([v'], Var v')
maxIdLevel :: LevelEnv -> VarSet -> Level
in
returnUs (env', vs'')
-subst_id_info (_, _, subst_env, _) ctxt_lvl dest_lvl v
+subst_id_info (_, _, subst, _) ctxt_lvl dest_lvl v
= modifyIdInfo (\info -> substIdInfo subst info (zap_dmd info)) v
where
- subst = mkSubst emptyVarSet subst_env
-
-- VERY IMPORTANT: we must zap the demand info
-- if the thing is going to float out past a lambda
zap_dmd info
opt_D_dump_rules,
opt_D_verbose_core2core,
opt_D_dump_occur_anal,
- opt_UsageSPOn,
+ opt_UsageSPOn
)
import CoreLint ( beginPass, endPass )
import CoreSyn
mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
-- The inlining black-list
- getBlackList,
+ setBlackList, getBlackList, noInlineBlackList,
-- Unique supply
getUniqueSmpl, getUniquesSmpl,
getEnv, setAllExceptInScope,
getSubst, setSubst,
getSubstEnv, extendSubst, extendSubstList,
- getInScope, setInScope, extendInScope, extendInScopes, modifyInScope,
+ getInScope, setInScope, modifyInScope, addNewInScopeIds,
setSubstEnv, zapSubstEnv,
- getSimplBinderStuff, setSimplBinderStuff,
- switchOffInlining
+ getSimplBinderStuff, setSimplBinderStuff
) where
#include "HsVersions.h"
import VarSet
import qualified Subst
import Subst ( Subst, mkSubst, substEnv,
- InScopeSet, substInScope, isInScope
+ InScopeSet, mkInScopeSet, substInScope, isInScope
)
import Type ( Type )
import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
-> SimplCount
-> (result, UniqSupply, SimplCount)
+type BlackList = Id -> Bool -- True => don't inline this Id
+
data SimplEnv
= SimplEnv {
seChkr :: SwitchChecker,
seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
- seBlackList :: Id -> Bool, -- True => don't inline this Id
+ seBlackList :: BlackList,
seSubst :: Subst -- The current substitution
}
-- The range of the substitution is OutType and OutExpr resp
initSmpl :: SwitchChecker
-> UniqSupply -- No init count; set to 0
-> VarSet -- In scope (usually empty, but useful for nested calls)
- -> (Id -> Bool) -- Black-list function
+ -> BlackList -- Black-list function
-> SimplM a
-> (a, SimplCount)
\end{code}
-@switchOffInlining@ is used to prepare the environment for simplifying
+@setBlackList@ is used to prepare the environment for simplifying
the RHS of an Id that's marked with an INLINE pragma. It is going to
be inlined wherever they are used, and then all the inlining will take
effect. Meanwhile, there isn't much point in doing anything to the
then we won't get deforestation at all.
We havn't solved this problem yet!
-We prepare the envt by simply modifying the in_scope_env, which has all the
-unfolding info. At one point we did it by modifying the chkr so that
-it said "EssentialUnfoldingsOnly", but that prevented legitmate, and
-important, simplifications happening in the body of the RHS.
+We prepare the envt by simply modifying the black list.
6/98 update:
selector, so failing to inline it in the RHS of `f' will
leave a reference to a non-existent id, with bad consequences.
-ALSO NOTE that we do all this by modifing the inline-pragma,
+ALSO NOTE that we do all this by modifing the black list
not by zapping the unfolding. The latter may still be useful for
knowing when something is evaluated.
-June 98 update: I've gone back to dealing with this by adding
-the EssentialUnfoldingsOnly switch. That doesn't stop essential
-unfoldings, nor inlineUnconditionally stuff; and the thing's going
-to be inlined at every call site anyway. Running over the whole
-environment seems like wild overkill.
-
\begin{code}
-switchOffInlining :: SimplM a -> SimplM a
-switchOffInlining m env us sc
- = m (env { seBlackList = \v -> not (isCompulsoryUnfolding (idUnfolding v)) &&
- not (isDataConWrapId v) &&
- ((v `isInScope` subst) || not (isLocallyDefined v))
- }) us sc
-
+setBlackList :: BlackList -> SimplM a -> SimplM a
+setBlackList black_list m env us sc = m (env { seBlackList = black_list }) us sc
+
+getBlackList :: SimplM BlackList
+getBlackList env us sc = (seBlackList env, us, sc)
+
+noInlineBlackList :: BlackList
-- Inside inlinings, black list anything that is in scope or imported.
-- except for things that must be unfolded (Compulsory)
-- and data con wrappers. The latter is a hack, like the one in
- -- SimplCore.simplRules, to make wrappers inline in rule LHSs. We
- -- may as well do the same here.
- where
- subst = seSubst env
+ -- SimplCore.simplRules, to make wrappers inline in rule LHSs.
+ -- We may as well do the same here.
+noInlineBlackList v = not (isCompulsoryUnfolding (idUnfolding v)) &&
+ not (isDataConWrapId v)
+ -- ((v `isInScope` subst) || not (isLocallyDefined v))
+ -- I don't see why we have these conditions
\end{code}
\begin{code}
-emptySimplEnv :: SwitchChecker -> InScopeSet -> (Id -> Bool) -> SimplEnv
+emptySimplEnv :: SwitchChecker -> VarSet -> (Id -> Bool) -> SimplEnv
emptySimplEnv sw_chkr in_scope black_list
= SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
seBlackList = black_list,
- seSubst = mkSubst in_scope emptySubstEnv }
+ seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv }
-- The top level "enclosing CC" is "SUBSUMED".
getEnv :: SimplM SimplEnv
getSubst :: SimplM Subst
getSubst env us sc = (seSubst env, us, sc)
-getBlackList :: SimplM (Id -> Bool)
-getBlackList env us sc = (seBlackList env, us, sc)
-
setSubst :: Subst -> SimplM a -> SimplM a
setSubst subst m env us sc = m (env {seSubst = subst}) 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 {seSubst = subst}) us sc
- = m (env {seSubst = Subst.extendInScope subst v}) us sc
-
-extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a
-extendInScopes vs m env@(SimplEnv {seSubst = subst}) us sc
- = m (env {seSubst = Subst.extendInScopes subst vs}) us sc
+addNewInScopeIds :: [CoreBndr] -> SimplM a -> SimplM a
+ -- The new Ids are guaranteed to be freshly allocated
+addNewInScopeIds vs m env@(SimplEnv {seSubst = subst}) us sc
+ = m (env {seSubst = Subst.extendNewInScopeList subst vs}) us sc
getInScope :: SimplM InScopeSet
getInScope env us sc = (substInScope (seSubst env), us, sc)
-- Extends the in-scope-env too
newId fs ty m env@(SimplEnv {seSubst = subst}) us sc
= case splitUniqSupply us of
- (us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc
+ (us1, us2) -> m v (env {seSubst = Subst.extendNewInScope subst v}) us2 sc
where
v = mkSysLocal fs (uniqFromSupply us1) ty
newIds :: UserFS -> [Type] -> ([Id] -> SimplM a) -> SimplM a
newIds fs tys m env@(SimplEnv {seSubst = subst}) us sc
= case splitUniqSupply us of
- (us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc
+ (us1, us2) -> m vs (env {seSubst = Subst.extendNewInScopeList subst vs}) us2 sc
where
vs = zipWithEqual "newIds" (mkSysLocal fs)
(uniqsFromSupply (length tys) us1) tys
-- The continuation type
SimplCont(..), DupFlag(..), contIsDupable, contResultType,
- pushArgs, discardCont, countValArgs, countArgs,
- analyseCont, discardInline
+ countValArgs, countArgs,
+ getContArgs, interestingCallContext, interestingArg, isStrictType, discardInline
) where
#include "HsVersions.h"
-import CmdLineOpts ( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge )
+import CmdLineOpts ( switchIsOn, SimplifierSwitch(..),
+ opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge, opt_DictsStrict
+ )
import CoreSyn
import CoreUnfold ( isValueUnfolding )
import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity, bindNonRec )
import Subst ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, lookupIdSubst )
import Id ( Id, idType, isId, idName,
- idOccInfo, idUnfolding,
+ idOccInfo, idUnfolding, idStrictness,
mkId, idInfo
)
-import IdInfo ( arityLowerBound, setOccInfo, vanillaIdInfo )
+import IdInfo ( StrictnessInfo(..), arityLowerBound, setOccInfo, vanillaIdInfo )
import Maybes ( maybeToBool, catMaybes )
import Name ( isLocalName, setNameUnique )
+import Demand ( Demand, isStrict, wwLazy, wwLazy )
import SimplMonad
import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, repType,
- splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
+ splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys,
+ isDictTy, isDataType, applyTy, splitFunTy, isUnLiftedType,
+ splitRepFunTys
)
import TyCon ( tyConDataConsIfAvailable )
import DataCon ( dataConRepArity )
import VarSet
import VarEnv ( SubstEnv, SubstResult(..) )
+import Util ( lengthExceeds )
import Outputable
\end{code}
| 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
+ OutType -- cont_ty: 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
+ -- The result expression in the OutExprStuff has type cont_ty
instance Outputable SimplCont where
ppr (Stop _) = ptext SLIT("Stop")
ppr OkToDup = ptext SLIT("ok")
ppr NoDup = ptext SLIT("nodup")
+-------------------
contIsDupable :: SimplCont -> Bool
contIsDupable (Stop _) = True
contIsDupable (ApplyTo OkToDup _ _ _) = True
contIsDupable (InlinePlease cont) = contIsDupable cont
contIsDupable other = False
-pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont
-pushArgs se [] cont = cont
-pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont)
+-------------------
+discardInline :: SimplCont -> SimplCont
+discardInline (InlinePlease cont) = cont
+discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
+discardInline cont = cont
+
+-------------------
+discardableCont :: SimplCont -> Bool
+discardableCont (Stop _) = False
+discardableCont (CoerceIt _ cont) = discardableCont cont
+discardableCont (InlinePlease cont) = discardableCont cont
+discardableCont other = True
discardCont :: SimplCont -- A continuation, expecting
-> SimplCont -- Replace the continuation with a suitable coerce
where
to_ty = contResultType cont
+-------------------
contResultType :: SimplCont -> OutType
contResultType (Stop to_ty) = to_ty
contResultType (ArgOf _ to_ty _) = to_ty
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
\end{code}
-Comment about analyseCont
-~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+getContArgs :: OutId -> SimplCont
+ -> SimplM ([(InExpr, SubstEnv, Bool)], -- Arguments; the Bool is true for strict args
+ SimplCont, -- Remaining continuation
+ Bool) -- Whether we came across an InlineCall
+-- getContArgs id k = (args, k', inl)
+-- args are the leading ApplyTo items in k
+-- (i.e. outermost comes first)
+-- augmented with demand info from the functionn
+getContArgs fun orig_cont
+ = getSwitchChecker `thenSmpl` \ chkr ->
+ let
+ -- Ignore strictness info if the no-case-of-case
+ -- flag is on. Strictness changes evaluation order
+ -- and that can change full laziness
+ stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts
+ | otherwise = computed_stricts
+ in
+ go [] stricts False orig_cont
+ where
+ ----------------------------
+
+ -- Type argument
+ go acc ss inl (ApplyTo _ arg@(Type _) se cont)
+ = go ((arg,se,False) : acc) ss inl cont
+ -- NB: don't bother to instantiate the function type
+
+ -- Value argument
+ go acc (s:ss) inl (ApplyTo _ arg se cont)
+ = go ((arg,se,s) : acc) ss inl cont
+
+ -- An Inline continuation
+ go acc ss inl (InlinePlease cont)
+ = go acc ss True cont
+
+ -- We're run out of arguments, or else we've run out of demands
+ -- The latter only happens if the result is guaranteed bottom
+ -- This is the case for
+ -- * case (error "hello") of { ... }
+ -- * (error "Hello") arg
+ -- * f (error "Hello") where f is strict
+ -- etc
+ go acc ss inl cont
+ | null ss && discardableCont cont = tick BottomFound `thenSmpl_`
+ returnSmpl (reverse acc, discardCont cont, inl)
+ | otherwise = returnSmpl (reverse acc, cont, inl)
+
+ ----------------------------
+ vanilla_stricts, computed_stricts :: [Bool]
+ vanilla_stricts = repeat False
+ computed_stricts = zipWith (||) fun_stricts arg_stricts
+
+ ----------------------------
+ (val_arg_tys, _) = splitRepFunTys (idType fun)
+ arg_stricts = map isStrictType val_arg_tys ++ repeat False
+ -- These argument types are used as a cheap and cheerful way to find
+ -- unboxed arguments, which must be strict. But it's an InType
+ -- and so there might be a type variable where we expect a function
+ -- type (the substitution hasn't happened yet). And we don't bother
+ -- doing the type applications for a polymorphic function.
+ -- Hence the split*Rep*FunTys
+
+ ----------------------------
+ -- If fun_stricts is finite, it means the function returns bottom
+ -- after that number of value args have been consumed
+ -- Otherwise it's infinite, extended with False
+ fun_stricts
+ = case idStrictness fun of
+ StrictnessInfo demands result_bot
+ | not (demands `lengthExceeds` countValArgs orig_cont)
+ -> -- Enough args, use the strictness given.
+ -- For bottoming functions we used to pretend that the arg
+ -- is lazy, so that we don't treat the arg as an
+ -- interesting context. This avoids substituting
+ -- top-level bindings for (say) strings into
+ -- calls to error. But now we are more careful about
+ -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
+ if result_bot then
+ map isStrict demands -- Finite => result is bottom
+ else
+ map isStrict demands ++ vanilla_stricts
+
+ other -> vanilla_stricts -- Not enough args, or no strictness
+
+
+-------------------
+isStrictType :: Type -> Bool
+ -- isStrictType computes whether an argument (or let RHS) should
+ -- be computed strictly or lazily, based only on its type
+isStrictType ty
+ | isUnLiftedType ty = True
+ | opt_DictsStrict && isDictTy ty && isDataType ty = True
+ | otherwise = False
+ -- 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)
+
+-------------------
+interestingArg :: InScopeSet -> InExpr -> SubstEnv -> Bool
+ -- 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 in_scope arg subst
+ = analyse arg
+ where
+ analyse (Var v)
+ = case lookupIdSubst (mkSubst in_scope subst) v of
+ DoneId v' _ -> hasSomeUnfolding (idUnfolding v')
+ -- was: isValueUnfolding (idUnfolding v')
+ -- But that seems over-pessimistic
+
+ other -> True -- was: False
+ -- But that is *definitely* too pessimistic.
+ -- E.g. let x = 3 in f
+ -- Here, x will be unconditionally substituted, via
+ -- the substitution!
+ analyse (Type _) = False
+ analyse (App fn (Type _)) = analyse fn
+ analyse (Note _ a) = analyse a
+ analyse other = True
+\end{code}
+
+Comment about interestingCallContext
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
default case.
\begin{code}
-analyseCont :: InScopeSet -> SimplCont
- -> ([Bool], -- Arg-info flags; one for each value argument
- Bool, -- Context of the result of the call is interesting
- Bool) -- There was an InlinePlease
-
-analyseCont in_scope cont
- = case cont of
+interestingCallContext :: Bool -- False <=> no args at all
+ -> Bool -- False <=> no value args
+ -> SimplCont -> Bool
-- The "lone-variable" case is important. I spent ages
-- messing about with unsatisfactory varaints, but this is nice.
-- The idea is that if a variable appear all alone
-- However, even a type application isn't a lone variable. Consider
-- case $fMonadST @ RealWorld of { :DMonad a b c -> c }
-- We had better inline that sucker! The case won't see through it.
-
- (Stop _) -> boring_result -- Don't inline a lone variable
- (Select _ _ _ _ _) -> boring_result -- Ditto
- (ArgOf _ _ _) -> boring_result -- Ditto
- (ApplyTo _ (Type _) _ cont) -> analyse_ty_app cont
- other -> analyse_app cont
+ --
+ -- For now, I'm treating treating a variable applied to types as
+ -- "lone". The motivating example was
+ -- f = /\a. \x. BIG
+ -- g = /\a. \y. h (f a)
+ -- There's no advantage in inlining f here, and perhaps
+ -- a significant disadvantage. Hence some_val_args in the Stop case
+
+interestingCallContext some_args some_val_args cont
+ = interesting cont
where
- boring_result = ([], False, False)
-
- -- For now, I'm treating not treating a variable applied to types as
- -- "lone". The motivating example was
- -- f = /\a. \x. BIG
- -- g = /\a. \y. h (f a)
- -- There's no advantage in inlining f here, and perhaps
- -- a significant disadvantage.
- analyse_ty_app (Stop _) = boring_result
- analyse_ty_app (ArgOf _ _ _) = boring_result
- analyse_ty_app (Select _ _ _ _ _) = ([], True, False) -- See the $fMonadST example above
- analyse_ty_app (ApplyTo _ (Type _) _ cont) = analyse_ty_app cont
- analyse_ty_app cont = analyse_app cont
-
- analyse_app (InlinePlease cont)
- = case analyse_app cont of
- (infos, icont, inline) -> (infos, icont, True)
-
- analyse_app (ApplyTo _ arg subst cont)
- | isValArg arg = case analyse_app cont of
- (infos, icont, inline) -> (analyse_arg subst arg : infos, icont, inline)
- | otherwise = analyse_app cont
-
- analyse_app cont = ([], interesting_call_context cont, False)
-
- -- 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.
- analyse_arg :: SubstEnv -> InExpr -> Bool
- analyse_arg subst (Var v) = case lookupIdSubst (mkSubst in_scope subst) v of
- DoneId v' _ -> isValueUnfolding (idUnfolding v')
- other -> False
- analyse_arg subst (Type _) = False
- analyse_arg subst (App fn (Type _)) = analyse_arg subst fn
- analyse_arg subst (Note _ a) = analyse_arg subst a
- analyse_arg subst other = True
-
- interesting_call_context (Stop ty) = canUpdateInPlace ty
- interesting_call_context (InlinePlease _) = True
- interesting_call_context (Select _ _ _ _ _) = True
- interesting_call_context (CoerceIt _ cont) = interesting_call_context cont
- interesting_call_context (ApplyTo _ (Type _) _ cont) = interesting_call_context cont
- interesting_call_context (ApplyTo _ _ _ _) = True
- interesting_call_context (ArgOf _ _ _) = True
+ interesting (InlinePlease _) = True
+ interesting (ApplyTo _ _ _ _) = some_args -- Can happen if we have (coerce t (f x)) y
+ interesting (Select _ _ _ _ _) = some_args
+ interesting (ArgOf _ _ _) = some_val_args
+ interesting (Stop ty) = some_val_args && canUpdateInPlace ty
+ interesting (CoerceIt _ cont) = interesting cont
-- 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.
-- the context for (f x) is not totally uninteresting.
-discardInline :: SimplCont -> SimplCont
-discardInline (InlinePlease cont) = cont
-discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
-discardInline cont = cont
-
+-------------------
+canUpdateInPlace :: Type -> Bool
-- Consider let x = <wurble> in ...
-- If <wurble> returns an explicit constructor, we might be able
-- to do update in place. So we treat even a thunk RHS context
--
-- 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:
+ -- where x occurs once in B. 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
+ -- the occurrences of x' will be just the occurrences originally
-- pinned on x.
poly_info = vanillaIdInfo `setOccInfo` idOccInfo var
returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
mk_silly_bind var rhs = NonRec var rhs
- -- The Inline note is really important! If we don't say
- -- INLINE on these silly little bindings then look what happens!
+ -- We need to be careful about inlining.
-- Suppose we start with:
--
-- x = let g = /\a -> \x -> f x x
-- /\ b -> let g* = g b in E
--
-- Then: * the binding for g gets floated out
- -- * but then it gets inlined into the rhs of g*
+ -- * but then it MIGHT get 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 INLINEd, so that
- -- we simply substitute for g* throughout.
+ -- We rely on the simplifier not to inline g into the RHS of g*,
+ -- because it's a "lone" occurrence, and there is no benefit in
+ -- inlining. But it's a slightly delicate property, and there's
+ -- a danger of making the simplifier loop here.
\end{code}
#include "HsVersions.h"
import CmdLineOpts ( switchIsOn, opt_SimplDoEtaReduction,
- opt_SimplNoPreInlining, opt_DictsStrict,
+ opt_SimplNoPreInlining,
SimplifierSwitch(..)
)
import SimplMonad
-import SimplUtils ( mkCase, transformRhs, findAlt,
+import SimplUtils ( mkCase, transformRhs, findAlt,
simplBinder, simplBinders, simplIds, findDefault,
- SimplCont(..), DupFlag(..), contResultType, analyseCont,
- discardInline, countArgs, countValArgs, discardCont, contIsDupable
+ SimplCont(..), DupFlag(..),
+ contResultType, discardInline, countArgs, contIsDupable,
+ getContArgs, interestingCallContext, interestingArg, isStrictType
)
import Var ( mkSysTyVar, tyVarKind )
import VarEnv
idUnfolding, setIdUnfolding, isExportedId, isDeadBinder,
idDemandInfo, setIdInfo,
idOccInfo, setIdOccInfo,
- zapLamIdInfo, idStrictness, setOneShotLambda,
+ zapLamIdInfo, setOneShotLambda,
)
-import IdInfo ( OccInfo(..), StrictnessInfo(..), ArityInfo(..),
+import IdInfo ( OccInfo(..), ArityInfo(..),
setArityInfo, setUnfoldingInfo,
occInfo
)
-import Demand ( Demand, isStrict, wwLazy )
+import Demand ( Demand, isStrict )
import DataCon ( dataConNumInstArgs, dataConRepStrictness,
dataConSig, dataConArgTys
)
import CostCentre ( currentCCS )
import Type ( mkTyVarTys, isUnLiftedType, seqType,
mkFunTy, splitFunTy, splitTyConApp_maybe,
- funResultTy, isDictTy, isDataType, applyTy
+ funResultTy
)
import Subst ( mkSubst, substTy, substExpr,
isInScope, lookupIdSubst, substIdInfo
)
-import TyCon ( isDataTyCon, tyConDataConsIfAvailable,
- isDataTyCon
- )
+import TyCon ( isDataTyCon, tyConDataConsIfAvailable )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( isLoopBreaker )
import Maybes ( maybeToBool )
-import Util ( zipWithEqual, lengthExceeds )
+import Util ( zipWithEqual )
import Outputable
\end{code}
loop for the simplifier is in SimplCore.lhs.
+-----------------------------------------
+ *** IMPORTANT NOTE ***
+-----------------------------------------
+The simplifier used to guarantee that the output had no shadowing, but
+it does not do so any more. (Actually, it never did!) The reason is
+documented with simplifyArgs.
+
+
+
+
%************************************************************************
%* *
\subsection{Bindings}
= case cont of
Stop _ -> -- Totally boring continuation
-- Don't inline inside an INLINE expression
- switchOffInlining (simplExpr e) `thenSmpl` \ e' ->
+ setBlackList noInlineBlackList (simplExpr e) `thenSmpl` \ e' ->
rebuild (mkInlineMe e') cont
other -> -- Dissolve the InlineMe note if there's
| otherwise
= -- Simplify the RHS
simplBinder bndr $ \ bndr' ->
- simplValArg (idType bndr') (idDemandInfo bndr)
- rhs rhs_se cont_ty $ \ rhs' ->
+ let
+ bndr_ty' = idType bndr'
+ is_strict = isStrict (idDemandInfo bndr) || isStrictType bndr_ty'
+ in
+ simplValArg bndr_ty' is_strict rhs rhs_se cont_ty $ \ rhs' ->
-- Now complete the binding and simplify the body
- if needsCaseBinding (idType bndr') rhs' then
+ if needsCaseBinding bndr_ty' rhs' then
addCaseBind bndr' rhs' thing_inside
else
completeBinding bndr bndr' False False rhs' thing_inside
seqType ty_arg' `seq`
returnSmpl ty_arg'
-simplValArg :: OutType -- Type of arg
- -> Demand -- Demand on the argument
+simplValArg :: OutType -- rhs_ty: Type of arg; used only occasionally
+ -> Bool -- True <=> evaluate eagerly
-> InExpr -> SubstEnv
- -> OutType -- Type of thing computed by the context
- -> (OutExpr -> SimplM OutExprStuff)
- -> SimplM OutExprStuff
-
-simplValArg 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)
+ -> OutType -- cont_ty: Type of thing computed by the context
+ -> (OutExpr -> SimplM OutExprStuff)
+ -- Takes an expression of type rhs_ty,
+ -- returns an expression of type cont_ty
+ -> SimplM OutExprStuff -- An expression of type cont_ty
+
+simplValArg arg_ty is_strict arg arg_se cont_ty thing_inside
+ | is_strict
= transformRhs arg `thenSmpl` \ t_arg ->
getEnv `thenSmpl` \ env ->
setSubstEnv arg_se $
simplExprF t_arg (ArgOf NoDup cont_ty $ \ rhs' ->
setAllExceptInScope env $
- etaFirst thing_inside rhs')
+ thing_inside (etaFirst rhs'))
| otherwise
= simplRhs False {- Not top level -}
thing_inside
-- Do eta-reduction on the simplified RHS, if eta reduction is on
--- NB: etaFirst only eta-reduces if that results in something trivial
-etaFirst | opt_SimplDoEtaReduction = \ thing_inside rhs -> thing_inside (etaCoreExprToTrivial rhs)
- | otherwise = \ thing_inside rhs -> thing_inside rhs
-
--- Try for eta reduction, but *only* if we get all
--- the way to an exprIsTrivial expression. We don't want to remove
--- extra lambdas unless we are going to avoid allocating this thing altogether
-etaCoreExprToTrivial rhs | exprIsTrivial rhs' = rhs'
- | otherwise = rhs
- where
- rhs' = etaReduceExpr rhs
+-- But *only* if we get all the way to an exprIsTrivial expression.
+-- We don't want to remove extra lambdas unless we are going
+-- to avoid allocating this thing altogether
+etaFirst rhs
+ | opt_SimplDoEtaReduction && exprIsTrivial rhs' = rhs'
+ | otherwise = rhs
+ where
+ rhs' = etaReduceExpr rhs
\end{code}
-- Making loop breakers not have an unfolding at all
-- means that we can avoid tests in exprIsConApp, for example.
-- This is important: if exprIsConApp says 'yes' for a recursive
- -- thing we can get into an infinite loop
+ -- thing, then we can get into an infinite loop
info_w_unf | isLoopBreaker (occInfo old_info) = new_bndr_info
| otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs
-- Simplify the RHS
getSubstEnv `thenSmpl` \ rhs_se ->
- simplRhs top_lvl False {- Not ok to float unboxed -}
+ simplRhs top_lvl False {- Not ok to float unboxed (conservative) -}
(idType bndr')
rhs rhs_se $ \ rhs' ->
\begin{code}
simplRhs :: Bool -- True <=> Top level
-> Bool -- True <=> OK to float unboxed (speculative) bindings
- -> OutType -> InExpr -> SubstEnv
+ -> OutType -- Type of RHS; used only occasionally
+ -> InExpr -> SubstEnv
-> (OutExpr -> SimplM (OutStuff a))
-> SimplM (OutStuff a)
simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside
-- Float lets out of RHS
let
- (floats_out, rhs'') | float_ubx = (floats, rhs')
- | otherwise = splitFloats floats rhs'
+ (floats_out, rhs'') = splitFloats float_ubx floats rhs'
in
if (top_lvl || wantToExpose 0 rhs') && -- Float lets if (a) we're at the top level
not (null floats_out) -- or (b) the resulting RHS is one we'd like to expose
WARN( any demanded_float floats_out, ppr floats_out )
addLetBinds floats_out $
setInScope in_scope' $
- etaFirst thing_inside rhs''
+ thing_inside (etaFirst rhs'')
-- in_scope' may be excessive, but that's OK;
-- it's a superset of what's in scope
else
-- Don't do the float
- etaFirst thing_inside (mkLets floats rhs')
+ thing_inside (etaFirst (mkLets floats rhs'))
-- In a let-from-let float, we just tick once, arbitrarily
-- choosing the first floated binder to identify it
-- 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
+-- If float_ubx is true we float all the bindings, otherwise
+-- we just float until we come across an unlifted one.
+-- Remember that the unlifted bindings in the floats are all for
+-- guaranteed-terminating non-exception-raising unlifted things,
+-- which we are happy to do speculatively. However, we may still
+-- not be able to float them out, because the context
-- is either a Rec group, or the top level, neither of which
-- can tolerate them.
-splitFloats floats rhs
- = go floats
+splitFloats float_ubx floats rhs
+ | float_ubx = (floats, rhs) -- Float them all
+ | otherwise = go floats
where
go [] = ([], rhs)
go (f:fs) | must_stay f = ([], mkLets (f:fs) rhs)
-- Dealing with a call
completeCall var occ cont
- = getBlackList `thenSmpl` \ black_list_fn ->
- getInScope `thenSmpl` \ in_scope ->
- getSwitchChecker `thenSmpl` \ chkr ->
+ = getBlackList `thenSmpl` \ black_list_fn ->
+ getInScope `thenSmpl` \ in_scope ->
+ getContArgs var cont `thenSmpl` \ (args, call_cont, inline_call) ->
let
- dont_use_rules = switchIsOn chkr DontApplyRules
- no_case_of_case = switchIsOn chkr NoCaseOfCase
black_listed = black_list_fn var
+ arg_infos = [ interestingArg in_scope arg subst
+ | (arg, subst, _) <- args, isValArg arg]
+
+ interesting_cont = interestingCallContext (not (null args))
+ (not (null arg_infos))
+ call_cont
- (arg_infos, interesting_cont, inline_call) = analyseCont in_scope cont
- discard_inline_cont | inline_call = discardInline cont
- | otherwise = cont
+ inline_cont | inline_call = discardInline cont
+ | otherwise = cont
maybe_inline = callSiteInline black_listed inline_call occ
var arg_infos interesting_cont
in
-- First, look for an inlining
-
case maybe_inline of {
Just unfolding -- There is an inlining!
-> tick (UnfoldingDone var) `thenSmpl_`
- simplExprF unfolding discard_inline_cont
+ simplExprF unfolding inline_cont
;
Nothing -> -- No inlining!
+
+ simplifyArgs (isDataConId var) args (contResultType call_cont) $ \ args' ->
+
-- Next, look for rules or specialisations that match
--
-- It's important to simplify the args first, because the rule-matcher
-- won't occur for things that have specialisations till a later phase, so
-- it's ok to try for inlining first.
- prepareArgs no_case_of_case var cont $ \ args' cont' ->
+ getSwitchChecker `thenSmpl` \ chkr ->
let
- maybe_rule | dont_use_rules = Nothing
- | otherwise = lookupRule in_scope var args'
+ maybe_rule | switchIsOn chkr DontApplyRules = Nothing
+ | otherwise = lookupRule in_scope var args'
in
case maybe_rule of {
Just (rule_name, rule_rhs) ->
tick (RuleFired rule_name) `thenSmpl_`
- simplExprF rule_rhs cont' ;
+ simplExprF rule_rhs call_cont ;
Nothing -> -- No rules
-- Done
- rebuild (mkApps (Var var) args') cont'
+ rebuild (mkApps (Var var) args') call_cont
}}
-\end{code}
-\begin{code}
---------------------------------------------------------
--- Preparing arguments for a call
-
-prepareArgs :: Bool -- True if the no-case-of-case switch is on
- -> OutId -> SimplCont
- -> ([OutExpr] -> SimplCont -> SimplM OutExprStuff)
- -> SimplM OutExprStuff
-prepareArgs no_case_of_case fun orig_cont thing_inside
- = go [] demands orig_fun_ty orig_cont
- where
- orig_fun_ty = idType fun
- is_data_con = isDataConId fun
-
- (demands, result_bot)
- | no_case_of_case = ([], False) -- Ignore strictness info if the no-case-of-case
- -- flag is on. Strictness changes evaluation order
- -- and that can change full laziness
- | otherwise
- = case idStrictness fun of
- StrictnessInfo demands result_bot
- | not (demands `lengthExceeds` countValArgs orig_cont)
- -> -- Enough args, use the strictness given.
- -- For bottoming functions we used to pretend that the arg
- -- is lazy, so that we don't treat the arg as an
- -- interesting context. This avoids substituting
- -- top-level bindings for (say) strings into
- -- calls to error. But now we are more careful about
- -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
- (demands, result_bot)
-
- other -> ([], False) -- Not enough args, or no strictness
-
- -- 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
-
- -- We've run out of demands, and the result is now bottom
- -- This deals with
- -- * case (error "hello") of { ... }
- -- * (error "Hello") arg
- -- * f (error "Hello") where f is strict
- -- etc
- go acc [] fun_ty cont
- | result_bot
- = tick_case_of_error cont `thenSmpl_`
- thing_inside (reverse acc) (discardCont cont)
-
- -- Type argument
- go acc ds fun_ty (ApplyTo _ arg@(Type ty_arg) se cont)
- = simplTyArg ty_arg se `thenSmpl` \ new_ty_arg ->
- go (Type new_ty_arg : acc) ds (applyTy fun_ty new_ty_arg) cont
-
- -- Value argument
- go acc ds fun_ty (ApplyTo _ val_arg se cont)
- | not is_data_con -- Function isn't a data constructor
- = simplValArg arg_ty dem val_arg se (contResultType cont) $ \ new_arg ->
- go (new_arg : acc) ds' res_ty cont
-
- | exprIsTrivial val_arg -- Function is a data contstructor, arg is trivial
- = getInScope `thenSmpl` \ in_scope ->
- let
- new_arg = substExpr (mkSubst in_scope se) val_arg
- -- Simplify the RHS with inlining switched off, so that
- -- only absolutely essential things will happen.
+-- Simplifying the arguments of a call
+
+simplifyArgs :: Bool -- It's a data constructor
+ -> [(InExpr, SubstEnv, Bool)] -- Details of the arguments
+ -> OutType -- Type of the continuation
+ -> ([OutExpr] -> SimplM OutExprStuff)
+ -> SimplM OutExprStuff
+
+-- Simplify the arguments to a call.
+-- This part of the simplifier may break the no-shadowing invariant
+-- Consider
+-- f (...(\a -> e)...) (case y of (a,b) -> e')
+-- where f is strict in its second arg
+-- If we simplify the innermost one first we get (...(\a -> e)...)
+-- Simplifying the second arg makes us float the case out, so we end up with
+-- case y of (a,b) -> f (...(\a -> e)...) e'
+-- So the output does not have the no-shadowing invariant. However, there is
+-- no danger of getting name-capture, because when the first arg was simplified
+-- we used an in-scope set that at least mentioned all the variables free in its
+-- static environment, and that is enough.
+--
+-- We can't just do innermost first, or we'd end up with a dual problem:
+-- case x of (a,b) -> f e (...(\a -> e')...)
+--
+-- I spent hours trying to recover the no-shadowing invariant, but I just could
+-- not think of an elegant way to do it. The simplifier is already knee-deep in
+-- continuations. We have to keep the right in-scope set around; AND we have
+-- to get the effect that finding (error "foo") in a strict arg position will
+-- discard the entire application and replace it with (error "foo"). Getting
+-- all this at once is TOO HARD!
+
+simplifyArgs is_data_con args cont_ty thing_inside
+ | not is_data_con
+ = go args thing_inside
+
+ | otherwise -- It's a data constructor, so we want
+ -- to switch off inlining in the arguments
-- If we don't do this, consider:
-- let x = +# p q in C {x}
-- Even though x get's an occurrence of 'many', its RHS looks cheap,
-- and there's a good chance it'll get inlined back into C's RHS. Urgh!
- --
- -- It's important that the substitution *does* deal with case-binder synonyms:
- -- case x of y { True -> (x,1) }
- -- Here we must be sure to substitute y for x when simplifying the args of the pair,
- -- to increase the chances of being able to inline x. The substituter will do
- -- that because the x->y mapping is held in the in-scope set.
- in
- -- It's not always the case that the new arg will be trivial
- -- Consider f x
- -- where, in one pass, f gets substituted by a constructor,
- -- but x gets substituted by an expression (assume this is the
- -- unique occurrence of x). It doesn't really matter -- it'll get
- -- fixed up next pass. And it happens for dictionary construction,
- -- which mentions the wrapper constructor to start with.
-
- go (new_arg : acc) ds' res_ty cont
-
- | otherwise
- = simplValArg arg_ty dem val_arg se (contResultType cont) $ \ new_arg ->
- -- A data constructor whose argument is now non-trivial;
- -- so let/case bind it.
- newId SLIT("a") arg_ty $ \ arg_id ->
- addNonRecBind arg_id new_arg $
- go (Var arg_id : acc) ds' res_ty cont
+ = getBlackList `thenSmpl` \ old_bl ->
+ setBlackList noInlineBlackList $
+ go args $ \ args' ->
+ setBlackList old_bl $
+ thing_inside args'
- where
- (arg_ty, res_ty) = splitFunTy fun_ty
- (dem, ds') = case ds of
- [] -> (wwLazy, [])
- (d:ds) -> (d,ds)
-
- -- We're run out of arguments and the result ain't bottom
- 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
-\end{code}
+ where
+ go [] thing_inside = thing_inside []
+ go (arg:args) thing_inside = simplifyArg is_data_con arg cont_ty $ \ arg' ->
+ go args $ \ args' ->
+ thing_inside (arg':args')
+
+simplifyArg is_data_con (Type ty_arg, se, _) cont_ty thing_inside
+ = simplTyArg ty_arg se `thenSmpl` \ new_ty_arg ->
+ thing_inside (Type new_ty_arg)
+
+simplifyArg is_data_con (val_arg, se, is_strict) cont_ty thing_inside
+ = getInScope `thenSmpl` \ in_scope ->
+ let
+ arg_ty = substTy (mkSubst in_scope se) (exprType val_arg)
+ in
+ if not is_data_con then
+ -- An ordinary function
+ simplValArg arg_ty is_strict val_arg se cont_ty thing_inside
+ else
+ -- A data constructor
+ -- simplifyArgs has already switched off inlining, so
+ -- all we have to do here is to let-bind any non-trivial argument
+
+ -- It's not always the case that new_arg will be trivial
+ -- Consider f x
+ -- where, in one pass, f gets substituted by a constructor,
+ -- but x gets substituted by an expression (assume this is the
+ -- unique occurrence of x). It doesn't really matter -- it'll get
+ -- fixed up next pass. And it happens for dictionary construction,
+ -- which mentions the wrapper constructor to start with.
+ simplValArg arg_ty is_strict val_arg se cont_ty $ \ arg' ->
+
+ if exprIsTrivial arg' then
+ thing_inside arg'
+ else
+ newId SLIT("a") (exprType arg') $ \ arg_id ->
+ addNonRecBind arg_id arg' $
+ thing_inside (Var arg_id)
+\end{code}
%************************************************************************
-- Build the join Id and continuation
-- We give it a "$j" name just so that for later amusement
-- we can identify any join points that don't end up as let-no-escapes
- newId SLIT("$j") (exprType join_rhs) $ \ join_id ->
+ -- [NOTE: the type used to be exprType join_rhs, but this seems more elegant.]
+ newId SLIT("$j") (mkFunTy join_arg_ty cont_ty) $ \ join_id ->
let
new_cont = ArgOf OkToDup cont_ty
(\arg' -> rebuild_done (App (Var join_id) arg'))
returnSmpl (concat alt_binds_s, alts')
) `thenSmpl` \ (alt_binds, alts') ->
- extendInScopes [b | NonRec b _ <- alt_binds] $
+ addNewInScopeIds [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
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
import CoreUtils ( eqExpr )
import PprCore ( pprCoreRule )
-import Subst ( Subst, InScopeSet, lookupSubst, extendSubst,
+import Subst ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst,
substEnv, setSubstEnv, emptySubst, isInScope,
- bindSubstList, unBindSubstList, substInScope
+ bindSubstList, unBindSubstList, substInScope, uniqAway
)
import Id ( Id, idUnfolding, zapLamIdInfo,
idSpecialisation, setIdSpecialisation,
insertRule rules new_rule@(Rule _ tpl_vars tpl_args _)
= go rules
where
- tpl_var_set = mkVarSet tpl_vars
+ tpl_var_set = mkInScopeSet (mkVarSet tpl_vars)
-- Actually we should probably include the free vars of tpl_args,
-- but I can't be bothered
tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, applyTys,
mkForAllTys, boxedTypeKind
)
-import Subst ( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList,
+import Subst ( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList, mkInScopeSet,
substId, substAndCloneId, substAndCloneIds, lookupIdSubst, substInScope
)
import Var ( TyVar, mkSysTyVar, setVarUnique )
-- accidentally re-use a unique that's already in use
-- Easiest thing is to do it all at once, as if all the top-level
-- decls were mutually recursive
- top_subst = mkSubst (mkVarSet (bindersOfBinds binds)) emptySubstEnv
+ top_subst = mkSubst (mkInScopeSet (mkVarSet (bindersOfBinds binds))) emptySubstEnv
go [] = returnSM ([], emptyUDs)
go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
mkSynTy, tidyOpenType, tidyOpenTypes
)
-import Subst ( emptyInScopeSet, mkSubst,
+import Subst ( emptyInScopeSet, mkSubst, mkInScopeSet,
substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
)
import Literal ( inIntRange )
FoundInst tenv dfun_id
-> let
- subst = mkSubst (tyVarsOfTypes tys) tenv
+ subst = mkSubst (mkInScopeSet (tyVarsOfTypes tys)) tenv
(tyvars, rho) = splitForAllTys (idType dfun_id)
ty_args = map subst_tv tyvars
dfun_rho = substTy subst rho
tcMonoBinds mbinds tc_ty_sigs is_rec
= tc_mb_pats mbinds `thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
let
- tv_list = bagToList tvs
id_list = bagToList ids
(names, mono_ids) = unzip id_list
import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod )
import TcEnv ( TcId, ValueEnv, TyThing(..), TyThingDetails(..), tcAddImportedIdInfo,
tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
- tcExtendLocalValEnv, tcExtendTyVarEnv
+ tcExtendLocalValEnv, tcExtendTyVarEnv, newDefaultMethodName
)
import TcBinds ( tcBindWithSigs, tcSpecSigs )
import TcTyDecls ( mkNewTyConRep )
import DataCon ( mkDataCon, dataConId, dataConWrapId, notMarkedStrict )
import Id ( Id, setInlinePragma, idUnfolding, idType, idName )
import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) )
-import NameSet ( emptyNameSet )
+import NameSet ( NameSet, mkNameSet, elemNameSet, emptyNameSet )
import Outputable
import Type ( Type, ThetaType, ClassContext,
mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, mkDictTys,
import VarSet ( mkVarSet, emptyVarSet )
import TyCon ( AlgTyConFlavour(..), mkClassTyCon )
import Maybes ( seqMaybe )
+import SrcLoc ( SrcLoc )
import FiniteMap ( lookupWithDefaultFM )
\end{code}
tcLookupTy class_name `thenTc` \ (AClass clas) ->
let
tyvars = classTyVars clas
+ dm_bndrs_w_locs = bagToList (collectMonoBinders def_methods)
+ dm_bndr_set = mkNameSet (map fst dm_bndrs_w_locs)
in
tcExtendTyVarEnv tyvars $
context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) ->
-- CHECK THE CLASS SIGNATURES,
- mapTc (tcClassSig rec_env clas tyvars)
+ mapTc (tcClassSig rec_env dm_bndr_set clas tyvars)
(filter isClassOpSig class_sigs) `thenTc` \ sig_stuff ->
-- MAKE THE CLASS DETAILS
tcClassSig :: ValueEnv -- Knot tying only!
+ -> NameSet -- Names bound in the default-method bindings
-> Class -- ...ditto...
-> [TyVar] -- The class type variable, used for error check only
-> RenamedClassOpSig
ClassOpItem) -- Selector Id, default-method Id, True if explicit default binding
-tcClassSig rec_env clas clas_tyvars
- (ClassOpSig op_name dm_name explicit_dm op_ty src_loc)
+tcClassSig rec_env dm_bind_names clas clas_tyvars
+ (ClassOpSig op_name maybe_dm_stuff op_ty src_loc)
= tcAddSrcLoc src_loc $
-- Check the type signature. NB that the envt *already has*
-- Build the selector id and default method id
sel_id = mkDictSelId op_name clas
- dm_id = mkDefaultMethodId dm_name clas global_ty
- final_dm_id = tcAddImportedIdInfo rec_env dm_id
in
- returnTc (local_ty, (sel_id, final_dm_id, explicit_dm))
+ (case maybe_dm_stuff of
+ Nothing -> -- Source-file class declaration
+ newDefaultMethodName op_name src_loc `thenNF_Tc` \ dm_name ->
+ returnNF_Tc (mkDefaultMethodId dm_name clas global_ty, op_name `elemNameSet` dm_bind_names)
+
+ Just (dm_name, explicit_dm) -> -- Interface-file class decl
+ let
+ dm_id = mkDefaultMethodId dm_name clas global_ty
+ in
+ returnNF_Tc (tcAddImportedIdInfo rec_env dm_id, explicit_dm)
+ ) `thenNF_Tc` \ (dm_id, explicit_dm) ->
+
+ returnTc (local_ty, (sel_id, dm_id, explicit_dm))
\end{code}
mkImplicitClassBinds classes
= returnNF_Tc (concat cls_ids_s, andMonoBindList binds_s)
-- The selector binds are already in the selector Id's unfoldings
+ -- We don't return the data constructor etc from the class,
+ -- because that's done via the class's TyCon
where
(cls_ids_s, binds_s) = unzip (map mk_implicit classes)
- mk_implicit clas = (all_cls_ids, binds)
+ mk_implicit clas = (sel_ids, binds)
where
- dict_con = classDataCon clas
- all_cls_ids = dataConId dict_con : cls_ids
- cls_ids = dataConWrapId dict_con : classSelIds clas
-
- -- The wrapper and selectors get bindings, the worker does not
- binds | isLocallyDefined clas = idsToMonoBinds cls_ids
+ sel_ids = classSelIds clas
+ binds | isLocallyDefined clas = idsToMonoBinds sel_ids
| otherwise = EmptyMonoBinds
\end{code}
tcDefaultMethodBinds clas default_binds sigs
= -- Check that the default bindings come from this class
- checkFromThisClass clas op_items default_binds `thenNF_Tc_`
+ checkFromThisClass clas default_binds `thenNF_Tc_`
-- Do each default method separately
-- For Hugs compatibility we make a default-method for every
\end{code}
\begin{code}
-checkFromThisClass :: Class -> [ClassOpItem] -> RenamedMonoBinds -> NF_TcM s ()
-checkFromThisClass clas op_items mono_binds
- = mapNF_Tc check_from_this_class bndrs `thenNF_Tc_`
+checkFromThisClass :: Class -> RenamedMonoBinds -> NF_TcM s ()
+checkFromThisClass clas mbinds
+ = mapNF_Tc check_from_this_class bndrs_w_locs `thenNF_Tc_`
returnNF_Tc ()
where
check_from_this_class (bndr, loc)
| nameOccName bndr `elem` sel_names = returnNF_Tc ()
| otherwise = tcAddSrcLoc loc $
addErrTc (badMethodErr bndr clas)
- sel_names = [getOccName sel_id | (sel_id,_,_) <- op_items]
- bndrs = bagToList (collectMonoBinders mono_binds)
+ sel_names = map getOccName (classSelIds clas)
+ bndrs_w_locs = bagToList (collectMonoBinders mbinds)
\end{code}
import CmdLineOpts ( opt_D_dump_deriv )
import TcMonad
-import TcEnv ( InstEnv, getEnvTyCons, tcSetInstEnv )
+import TcEnv ( InstEnv, getEnvTyCons, tcSetInstEnv, newDFunName )
import TcGenDeriv -- Deriv stuff
import TcInstUtil ( InstInfo(..), buildInstanceEnv )
import TcSimplify ( tcSimplifyThetas )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
-import RnEnv ( newDFunName, bindLocatedLocalsRn )
+import RnEnv ( bindLocatedLocalsRn )
import RnMonad ( RnNameSupply,
renameSourceCode, thenRn, mapRn, returnRn )
import DataCon ( dataConArgTys, isNullaryDataCon, isExistentialDataCon )
import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool, catMaybes )
-import Module ( ModuleName )
+import Module ( Module )
import Name ( isLocallyDefined, getSrcLoc,
Name, NamedThing(..),
OccName, nameOccName
%************************************************************************
\begin{code}
-tcDeriving :: ModuleName -- name of module under scrutiny
+tcDeriving :: Module -- name of module under scrutiny
-> FixityEnv -- for the deriving code (Show/Read.)
-> RnNameSupply -- for "renaming" bits of generated code
-> Bag InstInfo -- What we already know about instances
-> TcM s (Bag InstInfo, -- The generated "instance decls".
RenamedHsBinds) -- Extra generated bindings
-tcDeriving modname fixs rn_name_supply inst_decl_infos_in
+tcDeriving mod fixs rn_name_supply inst_decl_infos_in
= recoverTc (returnTc (emptyBag, EmptyBinds)) $
-- Fish the "deriving"-related information out of the TcEnv
-- Rename to get RenamedBinds.
-- The only tricky bit is that the extra_binds must scope over the
-- method bindings for the instances.
- (dfun_names_w_method_binds, rn_extra_binds)
- = renameSourceCode modname rn_name_supply (
+ (rn_method_binds_s, rn_extra_binds)
+ = renameSourceCode mod rn_name_supply (
bindLocatedLocalsRn (ptext (SLIT("deriving"))) mbinders $ \ _ ->
rnTopMonoBinds extra_mbinds [] `thenRn` \ (rn_extra_binds, _) ->
- mapRn rn_one method_binds_s `thenRn` \ dfun_names_w_method_binds ->
- returnRn (dfun_names_w_method_binds, rn_extra_binds)
+ mapRn rn_meths method_binds_s `thenRn` \ rn_method_binds_s ->
+ returnRn (rn_method_binds_s, rn_extra_binds)
)
- rn_one (cl_nm, tycon_nm, 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 = zipWith gen_inst_info
- new_inst_infos
- dfun_names_w_method_binds
-
- ddump_deriv = ddump_deriving really_new_inst_infos rn_extra_binds
in
- ioToTc (dumpIfSet opt_D_dump_deriv "Derived instances" ddump_deriv) `thenTc_`
+ mapNF_Tc gen_inst_info (new_inst_infos `zip` rn_method_binds_s) `thenNF_Tc` \ really_new_inst_infos ->
+
+ ioToTc (dumpIfSet opt_D_dump_deriv "Derived instances"
+ (ddump_deriving really_new_inst_infos rn_extra_binds)) `thenTc_`
returnTc (listToBag really_new_inst_infos, rn_extra_binds)
where
$$
ppr mbinds
where inst_decl_theta' = classesToPreds inst_decl_theta
+
+ -- Paste the dfun id and method binds into the InstInfo
+ gen_inst_info (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ locn _, meth_binds)
+ = newDFunName mod clas tys locn `thenNF_Tc` \ dfun_name ->
+ let
+ dfun_id = mkDictFunId dfun_name clas tyvars tys inst_decl_theta
+ in
+ returnNF_Tc (InstInfo clas tyvars tys inst_decl_theta
+ dfun_id meth_binds locn [])
+
+ rn_meths meths = rnMethodBinds meths `thenRn` \ (meths', _) -> returnRn meths'
+ -- Ignore the free vars returned
\end{code}
think_about_deriving = need_deriving local_data_tycons
(derive_these, _) = removeDups cmp_deriv think_about_deriving
- eqns = map mk_eqn derive_these
in
if null local_data_tycons then
returnTc [] -- Bale out now
-- Generate the method bindings for the required instance
-- (paired with class name, as we need that when generating dict
-- names.)
-gen_bind :: FixityEnv -> InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds)
+gen_bind :: FixityEnv -> InstInfo -> RdrNameMonoBinds
gen_bind fixities (InstInfo clas _ [ty] _ _ _ _ _)
- | not from_here
- = (clas_nm, tycon_nm, EmptyMonoBinds)
- | clas `hasKey` showClassKey
- = (clas_nm, tycon_nm, gen_Show_binds fixities tycon)
- | clas `hasKey` readClassKey
- = (clas_nm, tycon_nm, gen_Read_binds fixities tycon)
+ | not from_here = EmptyMonoBinds
+ | clas `hasKey` showClassKey = gen_Show_binds fixities tycon
+ | clas `hasKey` readClassKey = gen_Read_binds fixities tycon
| otherwise
- = (clas_nm, tycon_nm,
- assoc "gen_bind:bad derived class"
+ = assoc "gen_bind:bad derived class"
[(eqClassKey, gen_Eq_binds)
,(ordClassKey, gen_Ord_binds)
,(enumClassKey, gen_Enum_binds)
,(ixClassKey, gen_Ix_binds)
]
(classKey clas)
- tycon)
+ tycon
where
- clas_nm = nameOccName (getName clas)
- tycon_nm = nameOccName (getName tycon)
from_here = isLocallyDefined tycon
(tycon,_,_) = splitAlgTyConApp ty
-
-gen_inst_info :: InstInfo
- -> (Name, RenamedMonoBinds)
- -> InstInfo -- the gen'd (filled-in) "instance decl"
-
-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
- dfun_id
- meth_binds
- locn []
- where
- dfun_id = mkDictFunId dfun_name clas tyvars tys inst_decl_theta
-
- from_here = isLocallyDefined tycon
- (tycon,_,_) = splitAlgTyConApp ty
\end{code}
valueEnvIds,
newLocalId, newSpecPragmaId,
+ newDefaultMethodName, newDFunName,
tcGetGlobalTyVars, tcExtendGlobalTyVars,
InstEnv, emptyInstEnv, addToInstEnv,
import Type ( Kind, Type, superKind,
tyVarsOfType, tyVarsOfTypes,
splitForAllTys, splitRhoTy, splitFunTys,
- splitAlgTyConApp_maybe, getTyVar
+ splitAlgTyConApp_maybe, getTyVar, getDFunTyKey
)
import Subst ( substTy )
import UsageSPUtils ( unannotTy )
import BasicTypes ( Arity )
import IdInfo ( vanillaIdInfo )
-import Name ( Name, OccName, nameOccName, getSrcLoc,
+import Name ( Name, OccName, Provenance(..), ExportFlag(..), NamedThing(..),
+ nameOccName, nameModule, getSrcLoc, mkGlobalName,
maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
- NamedThing(..),
NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts,
extendNameEnv, extendNameEnvList
)
+import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
+import Module ( Module )
import Unify ( unifyTyListsX, matchTys )
import Unique ( pprUnique10, Unique, Uniquable(..) )
import UniqFM
identical = ins_item_more_specific && cur_item_more_specific
\end{code}
+Make a name for the dict fun for an instance decl
+
+\begin{code}
+newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM s Name
+newDFunName mod clas (ty:_) loc
+ = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq ->
+ tcGetUnique `thenNF_Tc` \ uniq ->
+ returnNF_Tc (mkGlobalName uniq mod
+ (mkDFunOcc dfun_string inst_uniq)
+ (LocalDef loc Exported))
+ where
+ -- Any string that is somewhat unique will do
+ dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
+
+newDefaultMethodName :: Name -> SrcLoc -> NF_TcM s Name
+newDefaultMethodName op_name loc
+ = tcGetUnique `thenNF_Tc` \ uniq ->
+ returnNF_Tc (mkGlobalName uniq (nameModule op_name)
+ (mkDefaultMethodOcc (getOccName op_name))
+ (LocalDef loc Exported))
+\end{code}
%************************************************************************
import Name ( Name )
import Class ( Class, FunDep, className, classExtraBigSig )
import Unify ( unifyTyListsX, matchTys )
-import Subst ( mkSubst, substTy )
+import Subst ( mkSubst, emptyInScopeSet, substTy )
import TcEnv ( tcGetInstEnv, classInstEnv )
import TcMonad
import TcType ( TcType, TcTyVar, TcTyVarSet, zonkTcType, zonkTcTypes )
= zonkUnifyTys free t_x s_x `thenTc` \ msubst ->
case msubst of
Just subst ->
- let t_y' = map (substTy (mkSubst emptyVarEnv subst)) t_y
- s_y' = map (substTy (mkSubst emptyVarEnv subst)) s_y
+ let full_subst = mkSubst emptyInScopeSet subst
+ t_y' = map (substTy full_subst) t_y
+ s_y' = map (substTy full_subst) s_y
in
zonkEqTys t_y' s_y' `thenTc` \ eq ->
if eq then
LIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
import TcEnv ( ValueEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths,
- tcAddImportedIdInfo, tcInstId
+ tcAddImportedIdInfo, tcInstId, newDFunName
)
import TcInstUtil ( InstInfo(..), classDataCon )
import TcMonoType ( tcHsSigType )
import Var ( idName, idType, Id, TyVar )
import Maybes ( maybeToBool, catMaybes, expectJust )
import MkId ( mkDictFunId )
-import Module ( ModuleName )
+import Module ( Module )
import Name ( isLocallyDefined, NamedThing(..) )
import NameSet ( emptyNameSet )
import PrelInfo ( eRROR_ID )
\begin{code}
tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids
-> [RenamedHsDecl]
- -> ModuleName -- module name for deriving
- -> FixityEnv
- -> RnNameSupply -- for renaming derivings
+ -> Module -- Module for deriving
+ -> FixityEnv -- For derivings
+ -> RnNameSupply -- For renaming derivings
-> TcM s (Bag InstInfo,
RenamedHsBinds)
-tcInstDecls1 unf_env decls mod_name fixs rn_name_supply
+tcInstDecls1 unf_env decls mod fixs rn_name_supply
= -- Do the ordinary instance declarations
- mapNF_Tc (tcInstDecl1 unf_env)
+ mapNF_Tc (tcInstDecl1 mod unf_env)
[inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags ->
let
decl_inst_info = unionManyBags inst_info_bags
-- Handle "derived" instances; note that we only do derivings
-- for things in this module; we ignore deriving decls from
-- interfaces!
- tcDeriving mod_name fixs rn_name_supply decl_inst_info
+ tcDeriving mod fixs rn_name_supply decl_inst_info
`thenTc` \ (deriv_inst_info, deriv_binds) ->
let
returnTc (full_inst_info, deriv_binds)
-tcInstDecl1 :: ValueEnv -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
+tcInstDecl1 :: Module -> ValueEnv -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
-tcInstDecl1 unf_env (InstDecl poly_ty binds uprags dfun_name src_loc)
+tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
= -- Prime error recovery, set source location
recoverNF_Tc (returnNF_Tc emptyBag) $
tcAddSrcLoc src_loc $
Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty)
in
- -- Check for respectable instance type, and context
- -- but only do this for non-imported instance decls.
- -- Imported ones should have been checked already, and may indeed
- -- contain something illegal in normal Haskell, notably
- -- instance CCallable [Char]
- (if isLocallyDefined dfun_name then
- scrutiniseInstanceHead clas inst_tys `thenNF_Tc_`
- mapNF_Tc scrutiniseInstanceConstraint constr
- else
- returnNF_Tc []
- ) `thenNF_Tc_`
-
- -- Make the dfun id
- let
- dfun_id = mkDictFunId dfun_name clas tyvars inst_tys constr
-
- -- Add info from interface file
- final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
- in
- returnTc (unitBag (InstInfo clas tyvars inst_tys constr
- final_dfun_id
- binds src_loc uprags))
+ (case maybe_dfun_name of
+ Nothing -> -- A source-file instance declaration
+
+ -- Check for respectable instance type, and context
+ -- but only do this for non-imported instance decls.
+ -- Imported ones should have been checked already, and may indeed
+ -- contain something illegal in normal Haskell, notably
+ -- instance CCallable [Char]
+ scrutiniseInstanceHead clas inst_tys `thenNF_Tc_`
+ mapNF_Tc scrutiniseInstanceConstraint constr `thenNF_Tc_`
+
+ -- Make the dfun id and return it
+ newDFunName mod clas inst_tys src_loc `thenNF_Tc` \ dfun_name ->
+ returnNF_Tc (mkDictFunId dfun_name clas tyvars inst_tys constr)
+
+ Just dfun_name -> -- An interface-file instance declaration
+ -- Make the dfun id and add info from interface file
+ let
+ dfun_id = mkDictFunId dfun_name clas tyvars inst_tys constr
+ in
+ returnNF_Tc (tcAddImportedIdInfo unf_env dfun_id)
+ ) `thenNF_Tc` \ dfun_id ->
+
+ returnTc (unitBag (InstInfo clas tyvars inst_tys constr dfun_id binds src_loc uprags))
\end{code}
| not (isLocallyDefined dfun_id)
= returnNF_Tc (emptyLIE, EmptyMonoBinds)
-{-
- -- I deleted this "optimisation" because when importing these
- -- instance decls the renamer would look for the dfun bindings and they weren't there.
- -- This would be fixable, but it seems simpler just to produce a tiny void binding instead,
- -- even though it's never used.
-
- -- This case deals with CCallable etc, which don't need any bindings
- | isNoDictClass clas
- = returnNF_Tc (emptyLIE, EmptyBinds)
--}
-
| otherwise
= -- Prime error recovery
recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
tcAddSrcLoc locn $
+ -- Check that all the method bindings come from this class
+ checkFromThisClass clas monobinds `thenNF_Tc_`
+
-- Instantiate the instance decl with tc-style type variables
tcInstId dfun_id `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->
let
newClassDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
- -- Check that all the method bindings come from this class
- checkFromThisClass clas op_items monobinds `thenNF_Tc_`
-
tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
tcExtendGlobalValEnv dm_ids (
-- Default-method Ids may be mentioned in synthesised RHSs
import Bag ( isEmptyBag )
import ErrUtils ( Message, printErrorsAndWarnings, dumpIfSet )
import Id ( Id, idType, idName )
-import Module ( pprModuleName )
+import Module ( pprModuleName, mkThisModule )
import OccName ( isSysOcc )
import Name ( Name, nameUnique, nameOccName, isLocallyDefined,
toRdrName, nameEnvElts, NamedThing(..)
)
-import TyCon ( TyCon, tyConKind )
+import TyCon ( TyCon, tyConKind, tyConClass_maybe )
import Class ( Class, classSelIds, classTyCon )
import PrelInfo ( mAIN_Name )
import Unique ( Unique, mainKey )
tcSetEnv env $
tcInstDecls1 unf_env decls
- mod_name fixities
- rn_name_supply `thenTc` \ (inst_info, deriv_binds) ->
+ (mkThisModule mod_name)
+ fixities rn_name_supply `thenTc` \ (inst_info, deriv_binds) ->
buildInstanceEnv inst_info `thenNF_Tc` \ inst_env ->
tcSetInstEnv inst_env $
let
- tycons = getEnvTyCons env
classes = getEnvClasses env
- local_tycons = filter isLocallyDefined tycons
+ tycons = getEnvTyCons env -- INCLUDES tycons derived from classes
local_classes = filter isLocallyDefined classes
+ local_tycons = [ tc | tc <- tycons,
+ isLocallyDefined tc,
+ Nothing <- [tyConClass_maybe tc]
+ ]
+ -- For local_tycons, filter out the ones derived from classes
+ -- Otherwise the latter show up in interface files
in
-- Default declarations
tcGetEnv, tcSetEnv,
tcGetDefaultTys, tcSetDefaultTys,
- tcGetUnique, tcGetUniques,
+ tcGetUnique, tcGetUniques, tcGetDFunUniq,
tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
tcAddErrCtxtM, tcSetErrCtxtM,
import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSM, initUs_ )
import SrcLoc ( SrcLoc, noSrcLoc )
+import FiniteMap ( FiniteMap, lookupFM, addToFM, emptyFM )
import UniqFM ( UniqFM, emptyUFM )
import Unique ( Unique )
import BasicTypes ( Unused )
initTc us initenv do_this
= do {
us_var <- newIORef us ;
+ dfun_var <- newIORef emptyFM ;
errs_var <- newIORef (emptyBag,emptyBag) ;
tvs_var <- newIORef emptyUFM ;
let
- init_down = TcDown [] us_var
+ init_down = TcDown [] us_var dfun_var
noSrcLoc
[] errs_var
init_env = initenv tvs_var
\begin{code}
forkNF_Tc :: NF_TcM s r -> NF_TcM s r
-forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
+forkNF_Tc m (TcDown deflts u_var df_var src_loc err_cxt err_var) env
= do
-- Get a fresh unique supply
us <- readIORef u_var
us_var' <- newIORef us2 ;
err_var' <- newIORef (emptyBag,emptyBag) ;
tv_var' <- newIORef emptyUFM ;
- let { down' = TcDown deflts us_var' src_loc err_cxt err_var' } ;
+ let { down' = TcDown deflts us_var' df_var src_loc err_cxt err_var' } ;
m down' env
-- ToDo: optionally dump any error messages
})
\end{code}
+\section{Dictionary function name supply
+%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tcGetDFunUniq :: String -> NF_TcM s Int
+tcGetDFunUniq key down env
+ = do dfun_supply <- readIORef d_var
+ let uniq = case lookupFM dfun_supply key of
+ Just x -> x+1
+ Nothing -> 0
+ let dfun_supply' = addToFM dfun_supply key uniq
+ writeIORef d_var dfun_supply'
+ return uniq
+ where
+ d_var = getDFunSupplyVar down
+\end{code}
+
+
\section{TcDown}
%~~~~~~~~~~~~~~~
[Type] -- Types used for defaulting
(TcRef UniqSupply) -- Unique supply
+ (TcRef DFunNameSupply) -- Name supply for dictionary function names
SrcLoc -- Source location
ErrCtxt -- Error context
- (TcRef (Bag WarnMsg,
- Bag ErrMsg))
+ (TcRef (Bag WarnMsg, Bag ErrMsg))
type ErrCtxt = [TidyEnv -> NF_TcM Unused (TidyEnv, Message)]
-- Innermost first. Monadic so that we have a chance
-- to deal with bound type variables just before error
-- message construction
+
+type DFunNameSupply = FiniteMap String Int
+ -- This is used as a name supply for dictionary functions
+ -- From the inst decl we derive a string, usually by glomming together
+ -- the class and tycon name -- but it doesn't matter exactly how;
+ -- this map then gives a unique int for each inst decl with that
+ -- string. (In Haskell 98 there can only be one,
+ -- but not so in more extended versions; also class CC type T
+ -- and class C type TT might both give the string CCT
+ --
+ -- We could just use one Int for all the instance decls, but this
+ -- way the uniques change less when you add an instance decl,
+ -- hence less recompilation
\end{code}
-- These selectors are *local* to TcMonad.lhs
\begin{code}
-getTcErrs (TcDown def us loc ctxt errs) = errs
-setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
+getTcErrs (TcDown def us ds loc ctxt errs) = errs
+setTcErrs (TcDown def us ds loc ctxt _ ) errs = TcDown def us ds loc ctxt errs
-getDefaultTys (TcDown def us loc ctxt errs) = def
-setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
+getDefaultTys (TcDown def us ds loc ctxt errs) = def
+setDefaultTys (TcDown _ us ds loc ctxt errs) def = TcDown def us ds loc ctxt errs
-getLoc (TcDown def us loc ctxt errs) = loc
-setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
+getLoc (TcDown def us ds loc ctxt errs) = loc
+setLoc (TcDown def us ds _ ctxt errs) loc = TcDown def us ds loc ctxt errs
-getUniqSupplyVar (TcDown def us loc ctxt errs) = us
+getUniqSupplyVar (TcDown def us ds loc ctxt errs) = us
+getDFunSupplyVar (TcDown def us ds loc ctxt errs) = ds
-setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
-addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
-getErrCtxt (TcDown def us loc ctxt errs) = ctxt
+setErrCtxt (TcDown def us ds loc ctxt errs) msg = TcDown def us ds loc [msg] errs
+addErrCtxt (TcDown def us ds loc ctxt errs) msg = TcDown def us ds loc (msg:ctxt) errs
+getErrCtxt (TcDown def us ds loc ctxt errs) = ctxt
\end{code}
kcHsContext context `thenTc_`
mapTc_ kc_sig (filter isClassOpSig class_sigs)
where
- kc_sig (ClassOpSig _ _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
+ kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
kcTyClDeclBody :: Name -> [HsTyVarBndr Name] -- Kind of the tycon/cls and its tyvars
-> (Kind -> TcM s a) -- Thing inside
get_sigs sigs
= unionManyUniqSets (map get_sig sigs)
where
- get_sig (ClassOpSig _ _ _ ty _) = get_ty ty
- get_sig (FixSig _) = emptyUniqSet
+ get_sig (ClassOpSig _ _ ty _) = get_ty ty
+ get_sig (FixSig _) = emptyUniqSet
get_sig other = panic "TcTyClsDecls:get_sig"
----------------------------------------------------
getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds,
isTauTy, mkRhoTy, splitRhoTy,
mkSigmaTy, isSigmaTy, splitSigmaTy,
+ getDFunTyKey,
-- Lifting and boxity
isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
import VarEnv
import VarSet
-import Name ( Name, NamedThing(..), mkLocalName, tidyOccName
- )
+import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName )
import NameSet
import Class ( classTyCon, Class, ClassPred, ClassContext )
import TyCon ( TyCon,
(theta,tau) = splitRhoTy rho
\end{code}
+\begin{code}
+getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
+ -- construct a dictionary function name
+getDFunTyKey (TyVarTy tv) = getOccName tv
+getDFunTyKey (TyConApp tc _) = getOccName tc
+getDFunTyKey (AppTy fun _) = getDFunTyKey fun
+getDFunTyKey (NoteTy _ t) = getDFunTyKey t
+getDFunTyKey (FunTy arg _) = getOccName funTyCon
+getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
+\end{code}
+
%************************************************************************
%* *
projects / ghc-hetmet.git / commitdiff