diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index ffa3272b7d7e980d1db6313fb11f92c1542faa7f..e9694d4e74b05d405a016e2d5627cd595f1e7e06 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -251,10 +251,10 @@ instantiated before use.
\begin{code}
mkTemplateLocals :: [Type] -> [Id]
mkTemplateLocals tys
- = zipWith mk (getBuiltinUniques (length tys)) tys
+ = zipWith3 mk (getBuiltinUniques (length tys)) tys [1..]
where
- mk uniq ty = mkVanillaId (mkSysLocalName uniq SLIT("tpl") mkBuiltinSrcLoc)
- ty noIdInfo
+ mk uniq ty n = mkVanillaId (mkSysLocalName uniq (_PK_ ("x"++show n)) mkBuiltinSrcLoc)
+ ty noIdInfo
\end{code}
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 5d285ffd2dc8a0526bf6254b33ab6742893f541a..d06fd93cb3ed07481955c23b965ffa69d8776677 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -53,6 +53,7 @@ import Id ( Id, idType, getIdArity, isBottomingId, isDataCon,
IdSet )
import PrimOp ( fragilePrimOp, primOpCanTriggerGC )
import IdInfo ( ArityInfo(..), InlinePragInfo(..) )
+import Name ( isExported )
import Literal ( isNoRepLit )
import TyCon ( tyConFamilySize )
import Type ( splitAlgTyConApp_maybe )
@@ -513,7 +514,9 @@ rule this out. Since ManyOcc doesn't record FunOcc/ArgOcc
inlineUnconditionally :: (Id,BinderInfo) -> Bool
inlineUnconditionally (id, occ_info)
- | idMustNotBeINLINEd id = False
+ | idMustNotBeINLINEd id
+ || isExported id
+ = False
| isOneSameSCCFunOcc occ_info
&& idWantsToBeINLINEd id = True
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 0f8c65770570dcf98528d109846206c384563c5a..b72b73e49980acc70e13d031c230e1ccbc3e21ff 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -315,10 +315,12 @@ ifaceId get_idinfo needed_ids is_rec id rhs
------------ Specialisations --------------
spec_pretty = hsep (map pp_spec (specEnvToList (getIdSpecialisation id)))
pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("_P_"),
- brackets (interpp'SP tyvars),
+ if null tyvars then ptext SLIT("[ ]")
+ else brackets (interpp'SP tyvars),
+ -- The lexer interprets "[]" as a CONID. Sigh.
hsep (map pprParendType tys),
ptext SLIT("="),
- ppr rhs
+ pprIfaceUnfolding rhs
]
------------ Extra free Ids --------------
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index f5a5576f22261acf6de41323f440522a18e72623..35043d8f5a29d79a3c7c044a2499bd3e58f44e67 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -486,8 +486,13 @@ id_info_item : ARITY_PART arity_info { HsArity $2 }
| strict_info { HsStrictness $1 }
| BOTTOM { HsStrictness HsBottom }
| UNFOLD_PART core_expr { HsUnfold $1 $2 }
- | SPECIALISE OBRACK tv_bndrs CBRACK
- atypes EQUAL core_expr { HsSpecialise $3 $5 $7 }
+ | SPECIALISE spec_tvs
+ atypes EQUAL core_expr { HsSpecialise $2 $3 $5 }
+
+
+spec_tvs :: { [HsTyVar RdrName] }
+spec_tvs : OBRACK tv_bndrs CBRACK { $2 }
+
arity_info :: { ArityInfo }
arity_info : INTEGER { exactArity (fromInteger $1) }
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index 29945aeffad71032a5f4f1ebe047da996e468093..a92ac88960d5fe0fc4bd57a013ea29064b464f24 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -25,7 +25,7 @@ import RdrHsSyn
import RnHsSyn
import RnMonad
import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
-import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn,
+import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, lookupGlobalOccRn,
newLocalNames, isUnboundName, warnUnusedBinds
)
import CmdLineOpts ( opt_SigsRequired )
@@ -341,23 +341,21 @@ rnMethodBinds (AndMonoBinds mb1 mb2)
= andRn AndMonoBinds (rnMethodBinds mb1)
(rnMethodBinds mb2)
-rnMethodBinds (FunMonoBind occname inf matches locn)
+rnMethodBinds (FunMonoBind name inf matches locn)
= pushSrcLocRn locn $
- mapRn (checkPrecMatch inf occname) matches `thenRn_`
+ mapRn (checkPrecMatch inf name) matches `thenRn_`
- newLocalNames [(occname, locn)] `thenRn` \ [op_name] ->
- -- Make a fresh local for the bound variable; it must be different
- -- to occurrences of the same thing on the LHS, which refer to the global
- -- selectors.
+ lookupGlobalOccRn name `thenRn` \ sel_name ->
+ -- We use the selector name as the binder
mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
- returnRn (FunMonoBind op_name inf new_matches locn)
+ returnRn (FunMonoBind sel_name inf new_matches locn)
-rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
+rnMethodBinds (PatMonoBind (VarPatIn name) grhss_and_binds locn)
= pushSrcLocRn locn $
- newLocalNames [(occname, locn)] `thenRn` \ [op_name] ->
+ lookupGlobalOccRn name `thenRn` \ sel_name ->
rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) ->
- returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
+ returnRn (PatMonoBind (VarPatIn sel_name) grhss_and_binds' locn)
-- Can't handle method pattern-bindings which bind multiple methods.
rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 7777049248eafbcdc6e8ea00bb1fb71267d7c4df..b70f54122b81ec0beb80d2e563a50cd7e563c0e4 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -276,37 +276,61 @@ ifaceFlavour name = case getNameProvenance name of
Looking up a name in the RnEnv.
\begin{code}
-lookupRn :: NameEnv -> RdrName -> RnMS s Name
-lookupRn name_env rdr_name
- = case lookupFM name_env rdr_name of
-
- -- Found it!
- Just name -> returnRn name
-
- -- Not found
- Nothing -> getModeRn `thenRn` \ mode ->
- case mode of
- -- Not found when processing source code; so fail
- SourceMode -> failWithRn (mkUnboundName rdr_name)
- (unknownNameErr rdr_name)
+checkUnboundRn :: RdrName -> Maybe Name -> RnMS s Name
+checkUnboundRn rdr_name (Just name)
+ = -- Found it!
+ returnRn name
+
+checkUnboundRn rdr_name Nothing
+ = -- Not found by lookup
+ 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 _ ->
- case rdr_name of
+ -- Not found when processing an imported declaration,
+ -- so we create a new name for the purpose
+ InterfaceMode _ _ ->
+ case rdr_name of
+ Qual mod_name occ hif -> newImportedGlobalName mod_name occ hif
- Qual mod_name occ hif -> newGlobalName mod_name occ hif
-
- -- An Unqual is allowed; interface files contain
- -- unqualified names for locally-defined things, such as
- -- constructors of a data type.
- Unqual occ -> getModuleRn `thenRn ` \ mod_name ->
- newGlobalName mod_name occ HiFile
+ -- An Unqual is allowed; interface files contain
+ -- unqualified names for locally-defined things, such as
+ -- constructors of a data type.
+ Unqual occ -> getModuleRn `thenRn ` \ mod_name ->
+ newImportedGlobalName mod_name occ HiFile
lookupBndrRn rdr_name
- = getNameEnv `thenRn` \ name_env ->
- lookupRn name_env rdr_name
+ = lookupNameRn rdr_name `thenRn` \ maybe_name ->
+ checkUnboundRn rdr_name maybe_name `thenRn` \ name ->
+
+ if isLocalName name then
+ returnRn name
+ else
+
+ ----------------------------------------------------
+ -- OK, so we're at the binding site of a top-level defn
+ -- Check to see whether its an imported decl
+ getModeRn `thenRn` \ mode ->
+ case mode of {
+ SourceMode -> returnRn name ;
+
+ InterfaceMode _ print_unqual_fn ->
+
+ ----------------------------------------------------
+ -- OK, the binding site of an *imported* defn
+ -- so we can make the provenance more informative
+ getSrcLocRn `thenRn` \ src_loc ->
+ let
+ name' = case getNameProvenance name of
+ NonLocalDef _ hif _ -> setNameProvenance name
+ (NonLocalDef src_loc hif (print_unqual_fn name'))
+ other -> name
+ in
+ returnRn name'
+ }
-- Just like lookupRn except that we record the occurrence too
-- Perhaps surprisingly, even wired-in names are recorded.
@@ -314,17 +338,25 @@ lookupBndrRn rdr_name
-- deciding which instance declarations to import.
lookupOccRn :: RdrName -> RnMS s Name
lookupOccRn rdr_name
- = getNameEnv `thenRn` \ name_env ->
- lookupRn name_env rdr_name `thenRn` \ name ->
- addOccurrenceName name
+ = lookupNameRn rdr_name `thenRn` \ maybe_name ->
+ checkUnboundRn rdr_name maybe_name `thenRn` \ name ->
+ let
+ name' = mungePrintUnqual rdr_name name
+ in
+ addOccurrenceName name'
-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
--- environment. It's used for record field names only.
+-- environment. It's used only for
+-- record field names
+-- class op names in class and instance decls
lookupGlobalOccRn :: RdrName -> RnMS s Name
lookupGlobalOccRn rdr_name
- = getGlobalNameEnv `thenRn` \ name_env ->
- lookupRn name_env rdr_name `thenRn` \ name ->
- addOccurrenceName name
+ = lookupGlobalNameRn rdr_name `thenRn` \ maybe_name ->
+ checkUnboundRn rdr_name maybe_name `thenRn` \ name ->
+ let
+ name' = mungePrintUnqual rdr_name name
+ in
+ addOccurrenceName name'
-- mungePrintUnqual is used to make *imported* *occurrences* print unqualified
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index f0ef83e872a0ac0836c9aac5a1d3d95e08cf3950..87ac92ddc38d952cd1ba54f4aab0231d103ad6af 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -39,6 +39,7 @@ import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
import Name
import UniqFM ( isNullUFM )
import UniqSet ( emptyUniqSet, unionManyUniqSets, UniqSet )
+import Unique ( assertIdKey )
import Util ( removeDups )
import Outputable
\end{code}
@@ -249,23 +250,15 @@ rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
rnExpr (HsVar v)
= lookupOccRn v `thenRn` \ name ->
- case res of
- Left (nm,err)
- | opt_GlasgowExts && v == assertRdrName ->
- -- if `assert' is not in scope,
- -- we expand it to (GHCerr.assert__ location)
- mkAssertExpr `thenRn` \ (expr, assert_name) ->
- returnRn (expr, unitNameSet assert_name)
-
- | otherwise -> -- a failure after all.
- failWithRn nm err `thenRn_`
- returnRn (HsVar nm, if isLocallyDefined nm
- then unitNameSet nm
- else emptyUniqSet)
- Right vname ->
- returnRn (HsVar vname, if isLocallyDefined vname
- then unitNameSet vname
- else emptyUniqSet)
+ if nameUnique name == assertIdKey then
+ -- We expand it to (GHCerr.assert__ location)
+ mkAssertExpr `thenRn` \ expr ->
+ returnRn (expr, emptyUniqSet)
+ else
+ -- The normal case
+ returnRn (HsVar name, if isLocallyDefined name
+ then unitNameSet name
+ else emptyUniqSet)
rnExpr (HsLit lit)
= litOccurrence lit `thenRn_`
@@ -732,7 +725,7 @@ litOccurrence (HsLitLit _)
%************************************************************************
\begin{code}
-mkAssertExpr :: RnMS s (RenamedHsExpr, Name)
+mkAssertExpr :: RnMS s RenamedHsExpr
mkAssertExpr =
newImportedGlobalName mod occ HiFile `thenRn` \ name ->
addOccurrenceName name `thenRn_`
@@ -741,7 +734,7 @@ mkAssertExpr =
expr = HsApp (HsVar name)
(HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
in
- returnRn (expr, name)
+ returnRn expr
where
mod = rdrNameModule assertErr_RDR
diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index a7f0eb3eaf3f165d36f6fe81328a08b67adb32e2..d8092261310941faabccc6fa33026b17fc47fb22 100644
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -34,7 +34,7 @@ import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import FoldrBuildWW ( mkFoldrBuildWW )
import MkId ( mkSysLocal, mkUserId )
-import Id ( setIdVisibility,
+import Id ( setIdVisibility, getIdSpecialisation, setIdSpecialisation,
getIdDemandInfo, idType,
nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
lookupIdEnv, IdEnv,
@@ -62,8 +62,9 @@ import SAT ( doStaticArgs )
import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
import SimplPgm ( simplifyPgm )
import Specialise
+import SpecEnv ( substSpecEnv, isEmptySpecEnv )
import StrictAnal ( saWwTopBinds )
-import TyVar ( TyVar, nameTyVar )
+import TyVar ( TyVar, nameTyVar, emptyTyVarEnv )
import Unique ( Unique{-instance Eq-}, Uniquable(..),
integerTyConKey, ratioTyConKey,
mkUnique, incrUnique,
@@ -72,7 +73,7 @@ import Unique ( Unique{-instance Eq-}, Uniquable(..),
import UniqSupply ( UniqSupply, mkSplitUniqSupply,
splitUniqSupply, getUnique
)
-import UniqFM ( UniqFM, lookupUFM, addToUFM )
+import UniqFM ( UniqFM, lookupUFM, addToUFM, delFromUFM )
import Util ( mapAccumL )
import SrcLoc ( noSrcLoc )
import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
@@ -608,19 +609,49 @@ mapTM f (x:xs) = f x `thenTM` \ r ->
\begin{code}
-- Need to extend the environment when we munge a binder, so that occurrences
--- of the binder will print the correct way (i.e. as a global not a local)
+-- of the binder will print the correct way (e.g. as a global not a local)
mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
mungeTopBinder id thing_inside mod env us
= -- Give it a new print-name unless it's an exported thing
-- setNameVisibility also does the local/global thing
let
- (id', us') | isExported id = (id, us)
+ (id1, us') | isExported id = (id, us)
| otherwise
= (setIdVisibility (Just mod) us id,
incrUnique us)
- new_env = addToUFM env id (ValBinder id')
+
+ -- Tidy the Id's SpecEnv
+ spec_env = getIdSpecialisation id
+ id2 | isEmptySpecEnv spec_env = id1
+ | otherwise = setIdSpecialisation id1 (tidySpecEnv env spec_env)
+
+ new_env = addToUFM env id (ValBinder id2)
in
- thing_inside id' mod new_env us'
+ thing_inside id2 mod new_env us'
+
+tidySpecEnv env spec_env
+ = substSpecEnv
+ emptyTyVarEnv -- Top level only
+ (tidy_spec_rhs env)
+ spec_env
+ where
+ -- tidy_spec_rhs is another horrid little hacked-up function for
+ -- the RHS of specialisation templates.
+ -- It assumes there is no type substitution.
+ --
+ -- See also SimplVar.substSpecEnvRhs Urgh
+ tidy_spec_rhs env (Var v) = case lookupUFM env v of
+ Just (ValBinder v') -> Var v'
+ Nothing -> Var v
+ tidy_spec_rhs env (App f (VarArg v)) = App (tidy_spec_rhs env f) (case lookupUFM env v of
+ Just (ValBinder v') -> VarArg v'
+ Nothing -> VarArg v)
+ tidy_spec_rhs env (App f arg) = App (tidy_spec_rhs env f) arg
+ tidy_spec_rhs env (Lam b e) = Lam b (tidy_spec_rhs env' e)
+ where
+ env' = case b of
+ ValBinder id -> delFromUFM env id
+ TyBinder _ -> env
mungeTopBinders [] k = k []
mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->
diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs
index 5daf73e129661e5c0d8b7a151c7d416b1c28bdc4..30b9381e9efb90a219ace6db7b9779af1bfe5112 100644
--- a/ghc/compiler/simplCore/SimplVar.lhs
+++ b/ghc/compiler/simplCore/SimplVar.lhs
@@ -198,7 +198,7 @@ simplBinder env (id, occ_info)
-- id2 has its SpecEnv zapped
id2 | isEmptySpecEnv spec_env = id1
- | otherwise = setIdSpecialisation id spec_env'
+ | otherwise = setIdSpecialisation id1 spec_env'
in
if not_in_scope then
-- No need to clone, but we *must* zap any current substitution
diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index c7d2ff49fd55baea42a508ccb7dbbcbc76172808..08f06491ad0a618e144b5f50e90189f85a23dc82 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -12,7 +12,7 @@ module Specialise (
#include "HsVersions.h"
import MkId ( mkUserLocal )
-import Id ( Id, DictVar, idType,
+import Id ( Id, DictVar, idType, mkTemplateLocals,
getIdSpecialisation, setIdSpecialisation, isSpecPragmaId,
@@ -26,7 +26,7 @@ import Type ( Type, mkTyVarTy, splitSigmaTy, instantiateTy, isDictTy,
tyVarsOfType, tyVarsOfTypes, applyTys, mkForAllTys
)
import TyCon ( TyCon )
-import TyVar ( TyVar,
+import TyVar ( TyVar, alphaTyVars,
TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets,
elementOfTyVarSet, unionTyVarSets, emptyTyVarSet,
TyVarEnv, mkTyVarEnv, delFromTyVarEnv
@@ -710,7 +710,7 @@ specBind (NonRec bndr rhs) body_uds
| isSpecPragmaId bndr
= specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
- returnSM ([], rhs_uds)
+ returnSM ([], rhs_uds `plusUDs` body_uds)
| otherwise
= -- Deal with the RHS, specialising it according
@@ -779,7 +779,7 @@ specDefn calls (fn, rhs)
(tyvars, theta, tau) = splitSigmaTy fn_type
n_tyvars = length tyvars
n_dicts = length theta
- mk_spec_tys call_ts = zipWith mk_spec_ty call_ts tyvars
+ mk_spec_tys call_ts = zipWith mk_spec_ty call_ts alphaTyVars
where
mk_spec_ty (Just ty) _ = ty
mk_spec_ty Nothing tyvar = mkTyVarTy tyvar
@@ -794,11 +794,6 @@ specDefn calls (fn, rhs)
Nothing -> []
Just cs -> fmToList cs
- -- Filter out calls for which we already have a specialisation
- calls_to_spec = filter spec_me calls_for_me
- spec_me (call_ts, _) = not (maybeToBool (lookupSpecEnv id_spec_env (mk_spec_tys call_ts)))
- id_spec_env = getIdSpecialisation fn
-
----------------------------------------------------------
-- Specialise to one particular call pattern
spec_call :: ProtoUsageDetails -- From the original body, captured by
@@ -817,13 +812,14 @@ specDefn calls (fn, rhs)
-- f1 = /\ b d -> (..rhs of f..) t1 b t3 d d1 d2
-- and the type of this binder
let
- spec_tyvars = [tyvar | (tyvar, Nothing) <- tyvars `zip` call_ts]
+ spec_tyvars = [tyvar | (tyvar, Nothing) <- alphaTyVars `zip` call_ts]
spec_tys = mk_spec_tys call_ts
spec_rhs = mkTyLam spec_tyvars $
mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds)
spec_id_ty = mkForAllTys spec_tyvars (instantiateTy ty_env tau)
ty_env = mkTyVarEnv (zipEqual "spec_call" tyvars spec_tys)
in
+
newIdSM fn spec_id_ty `thenSM` \ spec_f ->
@@ -833,8 +829,11 @@ specDefn calls (fn, rhs)
-- dictionaries, so it's tidier to make new local variables
-- for the lambdas in the RHS, rather than lambda-bind the
-- dictionaries themselves.
- mapSM (\d -> newIdSM d (idType d)) call_ds `thenSM` \ arg_ds ->
+ --
+ -- In fact we use the standard template locals, so that the
+ -- they don't need to be "tidied" before putting in interface files
let
+ arg_ds = mkTemplateLocals (map idType call_ds)
spec_env_rhs = mkValLam arg_ds $
mkTyApp (Var spec_f) $
map mkTyVarTy spec_tyvars
@@ -1074,6 +1073,7 @@ dictRhsFVs e
= go e
where
go (App e1 (VarArg a)) = go e1 `addOneToIdSet` a
+ go (App e1 (LitArg l)) = go e1
go (App e1 (TyArg t)) = go e1
go (Var v) = unitIdSet v
go (Lit l) = emptyIdSet
diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index be4a89b8cde98eb64a6f784830a37ef670fe6a82..790c9c6ac96143e72372c425a09b5fdebf2055e7 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -15,7 +15,7 @@ import CmdLineOpts ( opt_UnfoldingCreationThreshold )
import CoreUtils ( coreExprType )
import MkId ( mkWorkerId )
import Id ( getInlinePragma, getIdStrictness,
- addIdStrictness, addInlinePragma,
+ addIdStrictness, addInlinePragma, idWantsToBeINLINEd,
IdSet, emptyIdSet, addOneToIdSet,
GenId, Id
)
@@ -179,9 +179,10 @@ tryWW :: Id -- The fn binder
-- if two, then a worker and a
-- wrapper.
tryWW fn_id rhs
- | (certainlySmallEnoughToInline fn_id $
- calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
- )
+ | idWantsToBeINLINEd fn_id
+ || (certainlySmallEnoughToInline fn_id $
+ calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
+ )
-- No point in worker/wrappering something that is going to be
-- INLINEd wholesale anyway. If the strictness analyser is run
-- twice, this test also prevents wrappers (which are INLINEd)
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 6cc6a7a811e346036e043b869a2321e8c259a77f..00c1087e27f47f37aba2be2c651390322f32fd21 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -40,7 +40,7 @@ import MkId ( mkDataCon, mkSuperDictSelId,
mkMethodSelId, mkDefaultMethodId
)
import Id ( Id, StrictnessMark(..),
- getIdUnfolding, idType
+ getIdUnfolding, idType, idName
)
import CoreUnfold ( getUnfoldingTemplate )
import IdInfo
@@ -404,28 +404,27 @@ tcDefaultMethodBinds clas default_binds
-- Typecheck the default bindings
let
- tc_dm meth_bind
- | not (maybeToBool maybe_stuff)
- = -- Binding for something that isn't in the class signature
- failWithTc (badMethodErr bndr_name clas)
-
- | otherwise
- = -- Normal case
- tcMethodBind clas origin inst_tys clas_tyvars sel_id meth_bind [{- No prags -}]
+ tc_dm meth_bind
+ = case [pair | pair@(sel_id,_) <- sel_ids_w_dms,
+ idName sel_id == bndr_name] of
+
+ [] -> -- Binding for something that isn't in the class signature
+ failWithTc (badMethodErr bndr_name clas)
+
+ ((sel_id, Just dm_id):_) ->
+ -- We're looking at a default-method binding, so the dm_id
+ -- is sure to be there! Hence the inner "Just".
+ -- Normal case
+
+ tcMethodBind clas origin inst_tys clas_tyvars
+ sel_id meth_bind [{- No prags -}]
`thenTc` \ (bind, insts, (_, local_dm_id)) ->
- returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
+ returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
where
bndr_name = case meth_bind of
FunMonoBind name _ _ _ -> name
PatMonoBind (VarPatIn name) _ _ -> name
- maybe_stuff = assocMaybe assoc_list (nameOccName bndr_name)
- assoc_list = [ (getOccName sel_id, pair)
- | pair@(sel_id, dm_ie) <- op_sel_ids `zip` defm_ids
- ]
- Just (sel_id, Just dm_id) = maybe_stuff
- -- We're looking at a default-method binding, so the dm_id
- -- is sure to be there! Hence the inner "Just".
in
mapAndUnzip3Tc tc_dm
(flatten default_binds []) `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
@@ -454,6 +453,7 @@ tcDefaultMethodBinds clas default_binds
where
(tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
+ sel_ids_w_dms = op_sel_ids `zip` defm_ids
origin = ClassDeclOrigin
flatten EmptyMonoBinds rest = rest
@@ -481,19 +481,25 @@ tcMethodBind
tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind prags
= tcAddSrcLoc src_loc $
- newMethod origin (RealId sel_id) inst_tys `thenNF_Tc` \ meth@(_, TcId local_meth_id) ->
- tcInstSigTcType (idType local_meth_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
+ newMethod origin (RealId sel_id) inst_tys `thenNF_Tc` \ meth@(_, TcId meth_id) ->
+ tcInstSigTcType (idType meth_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
let
(theta', tau') = splitRhoTy rho_ty'
- sig_info = TySigInfo bndr_name local_meth_id tyvars' theta' tau' src_loc
+ sig_info = TySigInfo meth_name meth_id tyvars' theta' tau' src_loc
+ meth_name = idName meth_id
+ meth_bind' = case meth_bind of
+ FunMonoBind _ fix matches loc -> FunMonoBind meth_name fix matches loc
+ PatMonoBind (VarPatIn _) rhs loc -> PatMonoBind (VarPatIn meth_name) rhs loc
+ -- The renamer just puts the selector ID as the binder in the method binding
+ -- but we must use the method name; so we substitute it here. Crude but simple.
in
- tcExtendLocalValEnv [bndr_name] [local_meth_id] (
+ tcExtendLocalValEnv [meth_name] [meth_id] (
tcPragmaSigs prags
) `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
tcExtendGlobalTyVars inst_tyvars (
tcAddErrCtxt (methodCtxt sel_id) $
- tcBindWithSigs NotTopLevel [bndr_name] meth_bind [sig_info]
+ tcBindWithSigs NotTopLevel [meth_name] meth_bind' [sig_info]
NonRecursive prag_info_fn
) `thenTc` \ (binds, insts, _) ->
@@ -502,16 +508,16 @@ tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind prags
-- have not been unified with anything in the environment
tcAddErrCtxt (monoCtxt sel_id) (
tcAddErrCtxt (sigCtxt sel_id) $
- checkSigTyVars inst_tyvars (idType local_meth_id)
+ checkSigTyVars inst_tyvars (idType meth_id)
) `thenTc_`
returnTc (binds `AndMonoBinds` prag_binds,
insts `plusLIE` prag_lie,
meth)
where
- (bndr_name, src_loc) = case meth_bind of
- FunMonoBind name _ _ loc -> (name, loc)
- PatMonoBind (VarPatIn name) _ loc -> (name, loc)
+ src_loc = case meth_bind of
+ FunMonoBind name _ _ loc -> loc
+ PatMonoBind (VarPatIn name) _ loc -> loc
\end{code}
Contexts and errors
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index d59e0d5ba3e0804157f61cc4c87cecb5b5fc5343..a629162db6ed4ce4cde9e0a44841b9a7e855c61c 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -484,7 +484,7 @@ tcInstMethodBind clas inst_tys inst_tyvars meth_binds prags (sel_id, maybe_dm_id
sel_name = idName sel_id
meth_occ = getOccName sel_name
default_meth_name = mkLocalName uniq meth_occ loc
- maybe_meth_bind = find meth_occ meth_binds
+ maybe_meth_bind = find sel_name meth_binds
the_meth_bind = case maybe_meth_bind of
Just stuff -> stuff
Nothing -> mk_default_bind default_meth_name loc
@@ -503,14 +503,14 @@ tcInstMethodBind clas inst_tys inst_tyvars meth_binds prags (sel_id, maybe_dm_id
where
origin = InstanceDeclOrigin -- Poor
- find occ EmptyMonoBinds = Nothing
- find occ (AndMonoBinds b1 b2) = find occ b1 `seqMaybe` find occ b2
+ find sel EmptyMonoBinds = Nothing
+ find sel (AndMonoBinds b1 b2) = find sel b1 `seqMaybe` find sel b2
- find occ b@(FunMonoBind op_name _ _ _) | nameOccName op_name == occ = Just b
- | otherwise = Nothing
- find occ b@(PatMonoBind (VarPatIn op_name) _ _) | nameOccName op_name == occ = Just b
- | otherwise = Nothing
- find occ other = panic "Urk! Bad instance method binding"
+ find sel b@(FunMonoBind op_name _ _ _) | op_name == sel = Just b
+ | otherwise = Nothing
+ find sel b@(PatMonoBind (VarPatIn op_name) _ _) | op_name == sel = Just b
+ | otherwise = Nothing
+ find sel other = panic "Urk! Bad instance method binding"
mk_default_bind local_meth_name loc
diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs
index aa320011ac8eb5686f8fb59013e686de3d93a504..e0d41786bf5e1de660d3bcd0df240cead864e3f2 100644
--- a/ghc/compiler/types/TyVar.lhs
+++ b/ghc/compiler/types/TyVar.lhs
@@ -37,7 +37,7 @@ import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM, delFromUFM,
import BasicTypes ( Unused, unused )
import Name ( mkSysLocalName, mkLocalName, Name, NamedThing(..), OccName )
import SrcLoc ( noSrcLoc, SrcLoc )
-import Unique ( mkAlphaTyVarUnique, Unique, Uniquable(..) )
+import Unique ( initTyVarUnique, incrUnique, Unique, Uniquable(..) )
import Util ( zipEqual )
import Outputable
\end{code}
@@ -95,10 +95,10 @@ Fixed collection of type variables
-- openAlphaTyVar is prepared to be instantiated
-- to a boxed or unboxed type variable. It's used for the
-- result type for "error", so that we can have (error Int# "Help")
-openAlphaTyVar = TyVar (mkAlphaTyVarUnique 1) mkTypeKind Nothing unused
+openAlphaTyVar = TyVar initTyVarUnique mkTypeKind Nothing unused
alphaTyVars = [ TyVar u mkBoxedTypeKind Nothing unused
- | u <- map mkAlphaTyVarUnique [2..] ]
+ | u <- iterate incrUnique initTyVarUnique]
(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars