Commit fe69f3c1 authored by simonpj's avatar simonpj

[project @ 2000-08-01 09:08:25 by simonpj]

Simon's Marktoberdorf Commits

1.  Tidy up the renaming story for "system binders", such as
dictionary functions, default methods, constructor workers etc.  These
are now documented in HsDecls.  The main effect of the change, apart
from tidying up, is to make the *type-checker* (instead of the
renamer) generate names for dict-funs and default-methods.  This is
good because Sergei's generic-class stuff generates new classes at
typecheck time.


2.  Fix the CSE pass so it does not require the no-shadowing invariant.
Keith discovered that the simplifier occasionally returns a result
with shadowing.  After much fiddling around (which has improved the
code in the simplifier a bit) I found that it is nearly impossible to
arrange that it really does do no-shadowing.  So I gave up and fixed
the CSE pass (which is the only one to rely on it) instead.


3. Fix a performance bug in the simplifier.  The change is in
SimplUtils.interestingArg.  It computes whether an argment should 
be considered "interesting"; if a function is applied to an interesting
argument, we are more likely to inline that function.
Consider this case
	let x = 3 in f x
The 'x' argument was considered "uninteresting" for a silly reason.
Since x only occurs once, it was unconditionally substituted, but
interestingArg didn't take account of that case.  Now it does.

I also made interestingArg a bit more liberal.  Let's see if we
get too much inlining now.


4.  In the occurrence analyser, we were choosing a bad loop breaker.
Here's the comment that's now in OccurAnal.reOrderRec

    score ((bndr, rhs), _, _)
	| exprIsTrivial rhs 	   = 3	-- 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

I also increased the score for bindings with a non-functional type, so that
dictionaries have a better chance of getting inlined early


5. Add a hash code to the InScopeSet (and make it properly abstract)
This should make uniqAway a lot more robust.  Simple experiments suggest
that uniqAway no longer gets into the long iteration chains that it used
to.


6.  Fix a bug in the inliner that made the simplifier tend to get into
a loop where it would keep iterating ("4 iterations, bailing out" message).
In SimplUtils.mkRhsTyLam we float bindings out past a big lambda, thus:
	x = /\ b -> let g = \x -> f x x
		    in E
becomes
	g* = /\a -> \x -> f x x
	x = /\ b -> let g = g* b in E
	
It's essential that we don't simply inling g* back into the RHS of g,
else we will be back to square 1.  The inliner is meant not to do this
because there's no benefit to the inlining, but the size calculation
was a little off in CoreUnfold.


7.  In SetLevels we were bogus-ly building a Subst with an empty in-scope
set, so a WARNING popped up when compiling some modules.  (knights/ChessSetList
was the example that tickled it.)  Now in fact the warning wasn't an error,
but the Right Thing to do is to carry down a proper Subst in SetLevels, so
that is what I have now done.  It is very little more expensive.
parent 7185a7c3
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
......
......@@ -8,7 +8,7 @@ module Literal
( Literal(..) -- Exported to ParseIface
, mkMachInt, mkMachWord
, mkMachInt64, mkMachWord64
, isLitLitLit, maybeLitLit
, isLitLitLit, maybeLitLit, litIsDupable,
, literalType, literalPrimRep
, hashLiteral
......@@ -183,6 +183,12 @@ isLitLitLit _ = False
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
......
......@@ -23,7 +23,7 @@ module VarEnv (
SubstEnv, TyVarSubstEnv, SubstResult(..),
emptySubstEnv,
mkSubstEnv, lookupSubstEnv, extendSubstEnv, extendSubstEnvList,
delSubstEnv, noTypeSubst, isEmptySubstEnv
delSubstEnv, delSubstEnvList, noTypeSubst, isEmptySubstEnv
) where
#include "HsVersions.h"
......@@ -102,6 +102,9 @@ extendSubstEnvList (SE env nt) (b:bs) (r:rs) = extendSubstEnvList (SE (extendVar
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}
......
......@@ -13,16 +13,14 @@ module VarSet (
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
......@@ -91,20 +89,3 @@ seqVarSet :: VarSet -> ()
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}
......@@ -50,7 +50,7 @@ import Id ( Id, idType, idFlavour, isId, idWorkerInfo,
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
......@@ -192,7 +192,8 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr
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
......@@ -211,40 +212,39 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr
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
......@@ -306,7 +306,7 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr
------------
-- 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
......
......@@ -42,7 +42,7 @@ import Var ( Var, isId, isTyVar )
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 )
......@@ -271,7 +271,7 @@ exprIsTrivial other = False
\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
......
......@@ -6,14 +6,19 @@
\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,
......@@ -31,6 +36,7 @@ module Subst (
#include "HsVersions.h"
import CmdLineOpts ( opt_PprStyle_Debug )
import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr,
CoreRules(..), CoreRule(..),
emptyCoreRules, isEmptyCoreRules, seqRules
......@@ -49,6 +55,8 @@ import IdInfo ( IdInfo, isFragileOccInfo,
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
......@@ -56,15 +64,88 @@ import PprCore () -- Instances
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
......@@ -124,15 +205,6 @@ The general plan about the substitution and in-scope set for Ids is as follows
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
......@@ -177,38 +249,38 @@ lookupIdSubst (Subst in_scope env) v
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)
......@@ -218,7 +290,7 @@ unBindSubst :: Subst -> Var -> Var -> Subst
-- Reverse the effect of bindSubst
-- If old_bndr was already in the substitution, this doesn't quite work
unBindSubst (Subst in_scope env) old_bndr new_bndr
= Subst (in_scope `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
......@@ -251,14 +323,14 @@ setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2
%************************************************************************
\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
......@@ -325,7 +397,7 @@ substTyVar subst@(Subst in_scope env) old_var
--
-- 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)
......@@ -334,7 +406,7 @@ substTyVar subst@(Subst in_scope env) old_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
......@@ -437,7 +509,7 @@ substId :: Subst -> Id -> (Subst, Id)
-- 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
......@@ -476,7 +548,7 @@ substAndCloneIds subst us (b:bs) = case substAndCloneId subst us b of { (sub
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)
......
......@@ -14,7 +14,7 @@ import TcHsSyn ( TypecheckedRuleDecl )
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(..) )
......@@ -110,7 +110,7 @@ dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc)
(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
......
......@@ -236,9 +236,10 @@ data Sig name
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
......@@ -269,7 +270,7 @@ instance Eq name => Eq (FixitySig name) where
\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
......@@ -290,7 +291,7 @@ sigForThisGroup ns sig
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
......@@ -302,8 +303,8 @@ isFixitySig (FixSig _) = True
isFixitySig _ = False
isClassOpSig :: Sig name -> Bool
isClassOpSig (ClassOpSig _ _ _ _ _) = True
isClassOpSig _ = False
isClassOpSig (ClassOpSig _ _ _ _) = True
isClassOpSig _ = False
isPragSig :: Sig name -> Bool
-- Identifies pragmas
......@@ -316,7 +317,7 @@ isPragSig other = False
\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)
......@@ -332,10 +333,12 @@ ppr_sig :: Outputable name => Sig name -> SDoc
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],
......
......@@ -15,7 +15,7 @@ module HsDecls (
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"
......@@ -79,20 +79,24 @@ data HsDecl name pat
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}
......@@ -126,6 +130,48 @@ instance Ord name => Eq (HsDecl name pat) where
%* *
%************************************************************************
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
......@@ -189,8 +235,16 @@ instance Ord name => Eq (TyClDecl name pat) where
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