Skip to content

GitLab

GHC
GHC
Commit d0f325ce authored by simonpj's avatar simonpj
Browse files
Options

[project @ 1998-04-07 16:40:08 by simonpj] 

Specialiser really nearly working!
parent 8b935dd5
Hide whitespace changes
Inline Side-by-side
Showing with 202 additions and 131 deletions
ghc/compiler/basicTypes/Id.lhs
View file @ d0f325ce
......@@ -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}
......
ghc/compiler/coreSyn/CoreUnfold.lhs
View file @ d0f325ce
......@@ -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
......
ghc/compiler/main/MkIface.lhs
View file @ d0f325ce
......@@ -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 --------------
......
ghc/compiler/rename/ParseIface.y
View file @ d0f325ce
......@@ -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) }
......
ghc/compiler/rename/RnBinds.lhs
View file @ d0f325ce
......@@ -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)
......
ghc/compiler/rename/RnEnv.lhs
View file @ d0f325ce
......@@ -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
......
ghc/compiler/rename/RnExpr.lhs
View file @ d0f325ce
......@@ -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
......
ghc/compiler/simplCore/SimplCore.lhs
View file @ d0f325ce
......@@ -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' ->
......
ghc/compiler/simplCore/SimplVar.lhs
View file @ d0f325ce
......@@ -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
......
ghc/compiler/specialise/Specialise.lhs
View file @ d0f325ce
......@@ -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
......
ghc/compiler/stranal/WorkWrap.lhs
View file @ d0f325ce
......@@ -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)
......
ghc/compiler/typecheck/TcClassDcl.lhs
View file @ d0f325ce
......@@ -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
......
ghc/compiler/typecheck/TcInstDcls.lhs
View file @ d0f325ce
......@@ -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
......
ghc/compiler/types/TyVar.lhs
View file @ d0f325ce
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment