From d0f325ce37d6ee322168e44392f10e0ed52f8294 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 7 Apr 1998 16:40:45 +0000 Subject: [PATCH] [project @ 1998-04-07 16:40:08 by simonpj] Specialiser really nearly working! --- ghc/compiler/basicTypes/Id.lhs | 6 +- ghc/compiler/coreSyn/CoreUnfold.lhs | 5 +- ghc/compiler/main/MkIface.lhs | 6 +- ghc/compiler/rename/ParseIface.y | 9 ++- ghc/compiler/rename/RnBinds.lhs | 20 +++---- ghc/compiler/rename/RnEnv.lhs | 98 +++++++++++++++++++++----------- ghc/compiler/rename/RnExpr.lhs | 31 ++++------ ghc/compiler/simplCore/SimplCore.lhs | 45 ++++++++++++--- ghc/compiler/simplCore/SimplVar.lhs | 2 +- ghc/compiler/specialise/Specialise.lhs | 22 +++---- ghc/compiler/stranal/WorkWrap.lhs | 9 +-- ghc/compiler/typecheck/TcClassDcl.lhs | 58 ++++++++++--------- ghc/compiler/typecheck/TcInstDcls.lhs | 16 +++--- ghc/compiler/types/TyVar.lhs | 6 +- 14 files changed, 202 insertions(+), 131 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index ffa3272..e9694d4 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 5d285ff..d06fd93 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 0f8c657..b72b73e 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 f5a5576..35043d8 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 29945ae..a92ac88 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 7777049..b70f541 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 f0ef83e..87ac92d 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 a7f0eb3..d809226 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 5daf73e..30b9381 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 c7d2ff4..08f0649 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 be4a89b..790c9c6 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 6cc6a7a..00c1087e 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 d59e0d5..a629162 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 aa32001..e0d4178 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 -- 1.7.10.4