From: simonpj@microsoft.com Date: Fri, 29 Sep 2006 16:07:17 +0000 (+0000) Subject: Remove Linear Implicit Parameters, and all their works X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=bf40e268d916947786c56ec38db86190854a2d2c Remove Linear Implicit Parameters, and all their works Linear implicit parameters have been in GHC quite a while, but we decided they were a mis-feature and scheduled them for removal. This patch does the job. --- diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 0dbd0f6..d73e4f1 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -109,24 +109,18 @@ The @IPName@ type is here because it is used in TypeRep (i.e. very early in the hierarchy), but also in HsSyn. \begin{code} -data IPName name - = Dupable name -- ?x: you can freely duplicate this implicit parameter - | Linear name -- %x: you must use the splitting function to duplicate it +newtype IPName name = IPName name -- ?x deriving( Eq, Ord ) -- Ord is used in the IP name cache finite map -- (used in HscTypes.OrigIParamCache) - ipNameName :: IPName name -> name -ipNameName (Dupable n) = n -ipNameName (Linear n) = n +ipNameName (IPName n) = n mapIPName :: (a->b) -> IPName a -> IPName b -mapIPName f (Dupable n) = Dupable (f n) -mapIPName f (Linear n) = Linear (f n) +mapIPName f (IPName n) = IPName (f n) instance Outputable name => Outputable (IPName name) where - ppr (Dupable n) = char '?' <> ppr n -- Ordinary implicit parameters - ppr (Linear n) = char '%' <> ppr n -- Splittable implicit parameters + ppr (IPName n) = char '?' <> ppr n -- Ordinary implicit parameters \end{code} diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 394140d..406bf90 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -29,15 +29,15 @@ import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass, mkLocMessage, debugTraceMsg ) import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan ) import Type ( Type, tyVarsOfType, coreEqType, - splitFunTy_maybe, mkTyVarTys, + splitFunTy_maybe, splitForAllTy_maybe, splitTyConApp_maybe, isUnLiftedType, typeKind, mkForAllTy, mkFunTy, isUnboxedTupleType, isSubKind, substTyWith, emptyTvSubst, extendTvInScope, - TvSubst, TvSubstEnv, mkTvSubst, setTvSubstEnv, substTy, - extendTvSubst, composeTvSubst, substTyVarBndr, isInScope, - getTvSubstEnv, getTvInScope, mkTyVarTy ) -import Coercion ( Coercion, coercionKind, coercionKindPredTy ) + TvSubst, substTy, + extendTvSubst, substTyVarBndr, isInScope, + getTvInScope ) +import Coercion ( coercionKind, coercionKindPredTy ) import TyCon ( isPrimTyCon, isNewTyCon ) import BasicTypes ( RecFlag(..), Boxity(..), isNonRec ) import StaticFlags ( opt_PprStyle_Debug ) @@ -416,12 +416,6 @@ lintTyApp ty arg_ty ; checkKinds tyvar arg_ty ; return (substTyWith [tyvar] [arg_ty] body) } -lintTyApps fun_ty [] = return fun_ty - -lintTyApps fun_ty (arg_ty : arg_tys) = - do { fun_ty' <- lintTyApp fun_ty arg_ty - ; lintTyApps fun_ty' arg_tys } - checkKinds tyvar arg_ty -- Arg type might be boxed for a function with an uncommitted -- tyvar; notably this is used so that we can give diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index ac56176..983f2a8 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -24,7 +24,7 @@ module CoreSubst ( #include "HsVersions.h" -import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBind, +import CoreSyn ( Expr(..), Bind(..), CoreExpr, CoreBind, CoreRule(..), hasUnfolding, noUnfolding ) import CoreFVs ( exprFreeVars ) @@ -43,7 +43,7 @@ import IdInfo ( IdInfo, SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo, import Unique ( Unique ) import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply ) import Var ( Var, Id, TyVar, isTyVar ) -import Maybes ( orElse, isNothing ) +import Maybes ( orElse ) import Outputable import PprCore () -- Instances import Util ( mapAccumL ) diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 3db1a33..65ad53c 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -50,13 +50,11 @@ import StaticFlags ( opt_RuntimeTypes ) import CostCentre ( CostCentre, noCostCentre ) import Var ( Var, Id, TyVar, isTyVar, isId ) import Type ( Type, mkTyVarTy, seqType ) -import TyCon ( isNewTyCon ) import Coercion ( Coercion ) import Name ( Name ) import OccName ( OccName ) import Literal ( Literal, mkMachInt ) -import DataCon ( DataCon, dataConWorkId, dataConTag, dataConTyCon, - dataConWrapId ) +import DataCon ( DataCon, dataConWorkId, dataConTag ) import BasicTypes ( Activation ) import FastString import Outputable diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 40866f4..2d111ee 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -18,8 +18,7 @@ import HsBinds ( HsLocalBinds, DictBinds, isEmptyLocalBinds, HsWrapper, pprHsWrapper ) -- others: -import Type ( Type, pprParendType ) -import Var ( TyVar, Id ) +import Var ( Id ) import Name ( Name ) import BasicTypes ( IPName, Boxity, tupleParens, Arity, Fixity(..) ) import SrcLoc ( Located(..), unLoc ) diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 89e6500..41bcaed 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -18,11 +18,6 @@ import InstEnv ( OverlapFlag(..) ) import Class ( DefMeth(..) ) import CostCentre import StaticFlags ( opt_HiVersion, v_Build_tag ) -import Type ( Kind, - isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, - isArgTypeKind, isUbxTupleKind, liftedTypeKind, - unliftedTypeKind, openTypeKind, argTypeKind, - ubxTupleKind, mkArrowKind, splitFunTy_maybe ) import Panic import Binary import Util @@ -366,19 +361,9 @@ instance Binary Fixity where return (Fixity aa ab) instance (Binary name) => Binary (IPName name) where - put_ bh (Dupable aa) = do - putByte bh 0 - put_ bh aa - put_ bh (Linear ab) = do - putByte bh 1 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Dupable aa) - _ -> do ab <- get bh - return (Linear ab) + put_ bh (IPName aa) = put_ bh aa + get bh = do aa <- get bh + return (IPName aa) ------------------------------------------------------------------------- -- Types from: Demand diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 077edb2..dfa8ba2 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -15,9 +15,8 @@ module BuildTyCl ( import IfaceEnv ( newImplicitBinder ) import TcRnMonad -import DataCon ( DataCon, isNullarySrcDataCon, dataConUnivTyVars, - mkDataCon, dataConFieldLabels, dataConInstOrigArgTys, - dataConTyCon ) +import DataCon ( DataCon, isNullarySrcDataCon, + mkDataCon, dataConFieldLabels, dataConInstOrigArgTys ) import Var ( tyVarKind, TyVar, Id ) import VarSet ( isEmptyVarSet, intersectVarSet, elemVarSet ) import TysWiredIn ( unitTy ) @@ -25,23 +24,22 @@ import BasicTypes ( RecFlag, StrictnessMark(..) ) import Name ( Name ) import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc, mkClassDataConOcc, - mkSuperDictSelOcc, mkNewTyCoOcc, mkInstTyTcOcc, + mkSuperDictSelOcc, mkNewTyCoOcc, mkInstTyCoOcc ) import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId ) import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) ) import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta, tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ), - isRecursiveTyCon, tyConArity, AlgTyConRhs(..), + isRecursiveTyCon, AlgTyConRhs(..), SynTyConRhs(..), newTyConRhs, AlgTyConParent(..) ) import Type ( mkArrowKinds, liftedTypeKind, typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, splitTyConApp_maybe, splitAppTy_maybe, getTyVar_maybe, - mkPredTys, mkTyVarTys, ThetaType, Type, Kind, + mkPredTys, mkTyVarTys, ThetaType, Type, TyThing(..), - substTyWith, zipTopTvSubst, substTheta, mkForAllTys, - mkTyConApp, mkTyVarTy ) + substTyWith, zipTopTvSubst, substTheta ) import Coercion ( mkNewTypeCoercion, mkDataInstCoercion ) import Outputable import List ( nub ) diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index cea9508..6175965 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -22,18 +22,17 @@ import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName ) import TysWiredIn ( tupleTyCon, tupleCon ) import HscTypes ( NameCache(..), HscEnv(..), GenAvailInfo(..), IfaceExport, OrigNameCache ) -import Type ( mkOpenTvSubst, substTy ) import TyCon ( TyCon, tyConName ) import DataCon ( dataConWorkId, dataConName ) -import Var ( TyVar, Id, varName, setIdType, idType ) +import Var ( TyVar, Id, varName ) import Name ( Name, nameUnique, nameModule, nameOccName, nameSrcLoc, getOccName, nameParent_maybe, isWiredInName, mkIPName, mkExternalName, mkInternalName ) import NameSet ( NameSet, emptyNameSet, addListToNameSet ) -import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, mapOccEnv, occNameFS, - lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList ) +import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, occNameFS, + lookupOccEnv, unitOccEnv, extendOccEnv ) import PrelNames ( gHC_PRIM, dATA_TUP ) import Module ( Module, emptyModuleEnv, ModuleName, modulePackageId, lookupModuleEnv, extendModuleEnv_C, mkModule ) diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 4ebebe0..65c4fd3 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -36,22 +36,17 @@ import CoreSyn import IfaceType import NewDemand ( StrictSig, pprIfaceStrictSig ) -import TcType ( deNoteType ) import Class ( FunDep, DefMeth, pprFundeps ) import OccName ( OccName, parenSymOcc, occNameFS, OccSet, unionOccSets, unitOccSet, occSetElts ) import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM ) -import Name ( Name, NamedThing(..), nameOccName, isExternalName ) import CostCentre ( CostCentre, pprCostCentreCore ) import Literal ( Literal ) import ForeignCall ( ForeignCall ) import BasicTypes ( Arity, Activation(..), StrictnessMark, OverlapFlag, - RecFlag(..), Boxity(..), - isAlwaysActive, tupleParens ) + RecFlag(..), Boxity(..), tupleParens ) import Outputable import FastString -import Maybes ( catMaybes ) -import Util ( lengthIs ) infixl 3 &&& infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType` diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 63e8985..70399e7 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -26,12 +26,10 @@ module IfaceType ( #include "HsVersions.h" -import Type ( Kind ) -import Coercion ( Coercion ) import TypeRep ( TyThing(..), Type(..), PredType(..), ThetaType, unliftedTypeKindTyConName, openTypeKindTyConName, ubxTupleKindTyConName, argTypeKindTyConName, - liftedTypeKindTyConName, isLiftedTypeKind ) + liftedTypeKindTyConName ) import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity, tyConName ) import Var ( isId, tyVarKind, idType ) import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName ) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index bc11340..45da0d0 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -250,7 +250,6 @@ $white_no_nl+ ; <0,glaexts> { \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } - \% @varid / { ifExtension ipEnabled } { skip_one_varid ITsplitipvarid } } { @@ -442,7 +441,6 @@ data Token | ITqconsym (FastString,FastString) | ITdupipvarid FastString -- GHC extension: implicit param: ?x - | ITsplitipvarid FastString -- GHC extension: implicit param: %x | ITpragma StringBuffer diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index c650a7c..0fd1b4d 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -255,7 +255,6 @@ incorrect. QCONSYM { L _ (ITqconsym _) } IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension - IPSPLITVARID { L _ (ITsplitipvarid _) } -- GHC extension CHAR { L _ (ITchar _) } STRING { L _ (ITstring _) } @@ -1382,8 +1381,7 @@ dbind :: { LIPBind RdrName } dbind : ipvar '=' exp { LL (IPBind (unLoc $1) $3) } ipvar :: { Located (IPName RdrName) } - : IPDUPVARID { L1 (Dupable (mkUnqual varName (getIPDUPVARID $1))) } - | IPSPLITVARID { L1 (Linear (mkUnqual varName (getIPSPLITVARID $1))) } + : IPDUPVARID { L1 (IPName (mkUnqual varName (getIPDUPVARID $1))) } ----------------------------------------------------------------------------- -- Deprecations @@ -1648,7 +1646,6 @@ getQCONID (L _ (ITqconid x)) = x getQVARSYM (L _ (ITqvarsym x)) = x getQCONSYM (L _ (ITqconsym x)) = x getIPDUPVARID (L _ (ITdupipvarid x)) = x -getIPSPLITVARID (L _ (ITsplitipvarid x)) = x getCHAR (L _ (ITchar x)) = x getSTRING (L _ (ITstring x)) = x getINTEGER (L _ (ITinteger x)) = x diff --git a/compiler/prelude/PrelInfo.lhs b/compiler/prelude/PrelInfo.lhs index 88c8bb7..939c496 100644 --- a/compiler/prelude/PrelInfo.lhs +++ b/compiler/prelude/PrelInfo.lhs @@ -28,7 +28,6 @@ import PrelNames ( basicKnownKeyNames, import PrimOp ( PrimOp, allThePrimOps, primOpOcc, primOpTag, maxPrimOpTag ) import DataCon ( DataCon ) import Id ( Id, idName ) -import MkId ( mkPrimOpId, wiredInIds ) import MkId -- All of it, for re-export import Name ( nameOccName ) import TysPrim ( primTyCons ) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 0644654..03a9692 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -192,9 +192,6 @@ basicKnownKeyNames -- MonadFix monadFixClassName, mfixName, - -- Splittable class - splittableClassName, splitName, - -- Other classes randomClassName, randomGenClassName, monadPlusClassName, @@ -627,10 +624,6 @@ newStablePtrName = varQual gHC_STABLE FSLIT("newStablePtr") newStablePtrId -- PrelST module runSTRepName = varQual gHC_ST FSLIT("runSTRep") runSTRepIdKey --- The "split" Id for splittable implicit parameters -splittableClassName = clsQual gLA_EXTS FSLIT("Splittable") splittableClassKey -splitName = methName splittableClassName FSLIT("split") splitIdKey - -- Recursive-do notation monadFixClassName = clsQual mONAD_FIX FSLIT("MonadFix") monadFixClassKey mfixName = methName monadFixClassName FSLIT("mfix") mfixIdKey @@ -723,7 +716,6 @@ typeable6ClassKey = mkPreludeClassUnique 26 typeable7ClassKey = mkPreludeClassUnique 27 monadFixClassKey = mkPreludeClassUnique 28 -splittableClassKey = mkPreludeClassUnique 29 monadPlusClassKey = mkPreludeClassUnique 30 randomClassKey = mkPreludeClassUnique 31 @@ -921,7 +913,6 @@ printIdKey = mkPreludeMiscIdUnique 43 failIOIdKey = mkPreludeMiscIdUnique 44 nullAddrIdKey = mkPreludeMiscIdUnique 46 voidArgIdKey = mkPreludeMiscIdUnique 47 -splitIdKey = mkPreludeMiscIdUnique 48 fstIdKey = mkPreludeMiscIdUnique 49 sndIdKey = mkPreludeMiscIdUnique 50 otherwiseIdKey = mkPreludeMiscIdUnique 51 diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 1c8cc42..3bfde1c 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -28,7 +28,7 @@ module Inst ( tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag, isDict, isClassDict, isMethod, - isLinearInst, linearInstType, isIPDict, isInheritableInst, + isIPDict, isInheritableInst, isTyVarDict, isMethodFor, zonkInst, zonkInsts, @@ -63,7 +63,7 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcPredType, isIntTy,isFloatTy, isIntegerTy, isDoubleTy, mkPredTy, mkTyVarTys, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, - isClassPred, isTyVarClassPred, isLinearPred, + isClassPred, isTyVarClassPred, getClassPredTys, mkPredName, isInheritablePred, isIPPred, tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy, @@ -189,17 +189,6 @@ isMethod other = False isMethodFor :: TcIdSet -> Inst -> Bool isMethodFor ids (Method uniq id tys _ loc) = id `elemVarSet` ids isMethodFor ids inst = False - -isLinearInst :: Inst -> Bool -isLinearInst (Dict _ pred _) = isLinearPred pred -isLinearInst other = False - -- We never build Method Insts that have - -- linear implicit paramters in them. - -- Hence no need to look for Methods - -- See TcExpr.tcId - -linearInstType :: Inst -> TcType -- %x::t --> t -linearInstType (Dict _ (IParam _ ty) _) = ty \end{code} diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index e6ab82b..d9e25c3 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -45,7 +45,7 @@ import TcType ( TcType, TcSigmaType, TcRhoType, TvSubst, mkTyVarTys, mkFunTys, tcMultiSplitSigmaTy, tcSplitFunTysN, tcSplitTyConApp_maybe, - isSigmaTy, mkFunTy, mkTyConApp, isLinearPred, + isSigmaTy, mkFunTy, mkTyConApp, exactTyVarsOfType, exactTyVarsOfTypes, zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar ) @@ -796,19 +796,9 @@ instFun orig fun subst tv_theta_prs = do { co_fn <- instCall orig tys theta ; go False (HsWrap co_fn fun) prs } - -- Hack Alert (want_method_inst)! -- See Note [No method sharing] - -- If f :: (%x :: T) => Int -> Int - -- Then if we have two separate calls, (f 3, f 4), we cannot - -- make a method constraint that then gets shared, thus: - -- let m = f %x in (m 3, m 4) - -- because that loses the linearity of the constraint. - -- The simplest thing to do is never to construct a method constraint - -- in the first place that has a linear implicit parameter in it. - want_method_inst theta = not (null theta) -- Overloaded - && not (any isLinearPred theta) -- Not linear + want_method_inst theta = not (null theta) -- Overloaded && not opt_NoMethodSharing - -- See Note [No method sharing] below \end{code} Note [Multiple instantiation] diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 9fa0d6b..026893c 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -1,4 +1,4 @@ -% + % % (c) The AQUA Project, Glasgow University, 1996-1998 % \section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker} @@ -651,8 +651,7 @@ zonkRbinds env rbinds ------------------------------------------------------------------------- mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b) -mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r) -mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r) +mapIPNameTc f (IPName n) = f n `thenM` \ r -> returnM (IPName r) \end{code} diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index b7b8bd2..ba1888d 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -50,11 +50,11 @@ import HscTypes ( FixityEnv, availName, IsBootInterface, Deprecations ) import Packages ( PackageId ) import Type ( Type, pprTyThingCategory ) -import TcType ( TcTyVarSet, TcType, TcThetaType, SkolemInfo, TvSubst, +import TcType ( TcTyVarSet, TcType, TcThetaType, SkolemInfo, TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes, pprSkolInfo ) import InstEnv ( Instance, InstEnv ) -import FamInstEnv ( FamInst, FamInstEnv ) +import FamInstEnv ( FamInstEnv ) import IOEnv import RdrName ( GlobalRdrEnv, LocalRdrEnv ) import Name ( Name ) @@ -67,7 +67,6 @@ import UniqFM import SrcLoc ( SrcSpan, SrcLoc, Located, srcSpanStart ) import VarSet ( IdSet ) import ErrUtils ( Messages, Message ) -import UniqFM ( UniqFM ) import UniqSupply ( UniqSupply ) import BasicTypes ( IPName ) import Util ( thenCmp ) diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 7379993..1a5b743 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -22,44 +22,43 @@ module TcSimplify ( import {-# SOURCE #-} TcUnify( unifyType ) import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, mkWpTyApps, - HsWrapper(..), (<.>), nlHsTyApp, emptyLHsBinds ) -import TcHsSyn ( mkHsApp ) + HsWrapper(..), (<.>), emptyLHsBinds ) import TcRnMonad import Inst ( lookupInst, LookupInstResult(..), tyVarsOfInst, fdPredsOfInsts, - isDict, isClassDict, isLinearInst, linearInstType, + isDict, isClassDict, isMethodFor, isMethod, - instToId, tyVarsOfInsts, cloneDict, + instToId, tyVarsOfInsts, ipNamesOfInsts, ipNamesOfInst, dictPred, fdPredsOfInst, - newDictBndrs, newDictBndrsO, tcInstClassOp, + newDictBndrs, newDictBndrsO, getDictClassTys, isTyVarDict, instLoc, zonkInst, tidyInsts, tidyMoreInsts, pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs, isInheritableInst, pprDictsTheta ) -import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders, +import TcEnv ( tcGetGlobalTyVars, findGlobals, pprBinders, lclEnvElts, tcMetaTy ) import InstEnv ( lookupInstEnv, classInstances, pprInstances ) import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, zonkTcPredType ) import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType, tidyPred, - mkClassPred, isOverloadedTy, mkTyConApp, isSkolemTyVar, + mkClassPred, isOverloadedTy, isSkolemTyVar, mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys, tyVarsOfPred, tcEqType, pprPred, mkPredTy, tcIsTyVarTy ) import TcIface ( checkWiredInTyCon ) -import Id ( idType, mkUserLocal ) +import Id ( idType ) import Var ( TyVar ) import TyCon ( TyCon ) -import Name ( Name, getOccName, getSrcLoc ) +import Name ( Name ) import NameSet ( NameSet, mkNameSet, elemNameSet ) import Class ( classBigSig, classKey ) import FunDeps ( oclose, grow, improve, pprEquation ) import PrelInfo ( isNumericClass, isStandardClass ) -import PrelNames ( splitName, fstName, sndName, integerTyConName, +import PrelNames ( integerTyConName, showClassKey, eqClassKey, ordClassKey ) import Type ( zipTopTvSubst, substTheta, substTy ) -import TysWiredIn ( pairTyCon, doubleTy, doubleTyCon ) +import TysWiredIn ( doubleTy, doubleTyCon ) import ErrUtils ( Message ) import BasicTypes ( TopLevelFlag, isNotTopLevel ) import VarSet @@ -1386,23 +1385,11 @@ data Avail | Given TcId -- Used for dictionaries for which we have a binding -- e.g. those "given" in a signature - Bool -- True <=> actually consumed (splittable IPs only) | Rhs -- Used when there is a RHS (LHsExpr TcId) -- The RHS [Inst] -- Insts free in the RHS; we need these too - | Linear -- Splittable Insts only. - Int -- The Int is always 2 or more; indicates how - -- many copies are required - Inst -- The splitter - Avail -- Where the "master copy" is - - | LinRhss -- Splittable Insts only; this is used only internally - -- by extractResults, where a Linear - -- is turned into an LinRhss - [LHsExpr TcId] -- A supply of suitable RHSs - pprAvails avails = vcat [sep [ppr inst, nest 2 (equals <+> pprAvail avail)] | (inst,avail) <- fmToList avails ] @@ -1411,11 +1398,8 @@ instance Outputable Avail where pprAvail IsFree = text "Free" pprAvail Irred = text "Irred" -pprAvail (Given x b) = text "Given" <+> ppr x <+> - if b then text "(used)" else empty +pprAvail (Given x) = text "Given" <+> ppr x pprAvail (Rhs rhs bs) = text "Rhs" <+> ppr rhs <+> braces (ppr bs) -pprAvail (Linear n i a) = text "Linear" <+> ppr n <+> braces (ppr i) <+> ppr a -pprAvail (LinRhss rhss) = text "LinRhss" <+> ppr rhss \end{code} Extracting the bindings from a bunch of Avails. @@ -1445,8 +1429,8 @@ extractResults avails wanteds Just IsFree -> go (add_free avails w) binds irreds (w:frees) ws Just Irred -> go (add_given avails w) binds (w:irreds) frees ws - Just (Given id _) -> go avails new_binds irreds frees ws - where + Just (Given id) -> go avails new_binds irreds frees ws + where new_binds | id == instToId w = binds | otherwise = addBind binds w (L (instSpan w) (HsVar id)) -- The sought Id can be one of the givens, via a superclass chain @@ -1456,27 +1440,7 @@ extractResults avails wanteds where new_binds = addBind binds w rhs - Just (Linear n split_inst avail) -- Transform Linear --> LinRhss - -> get_root irreds frees avail w `thenM` \ (irreds', frees', root_id) -> - split n (instToId split_inst) root_id w `thenM` \ (binds', rhss) -> - go (addToFM avails w (LinRhss rhss)) - (binds `unionBags` binds') - irreds' frees' (split_inst : w : ws) - - Just (LinRhss (rhs:rhss)) -- Consume one of the Rhss - -> go new_avails new_binds irreds frees ws - where - new_binds = addBind binds w rhs - new_avails = addToFM avails w (LinRhss rhss) - - -- get_root is just used for Linear - get_root irreds frees (Given id _) w = returnM (irreds, frees, id) - get_root irreds frees Irred w = cloneDict w `thenM` \ w' -> - returnM (w':irreds, frees, instToId w') - get_root irreds frees IsFree w = cloneDict w `thenM` \ w' -> - returnM (irreds, w':frees, instToId w') - - add_given avails w = addToFM avails w (Given (instToId w) True) + add_given avails w = addToFM avails w (Given (instToId w)) add_free avails w | isMethod w = avails | otherwise = add_given avails w @@ -1494,58 +1458,6 @@ extractResults avails wanteds -- t1=t3; but alas, the binding for t2 (which mentions t1) -- will continue to float out! -split :: Int -> TcId -> TcId -> Inst - -> TcM (TcDictBinds, [LHsExpr TcId]) --- (split n split_id root_id wanted) returns --- * a list of 'n' expressions, all of which witness 'avail' --- * a bunch of auxiliary bindings to support these expressions --- * one or zero insts needed to witness the whole lot --- (maybe be zero if the initial Inst is a Given) --- --- NB: 'wanted' is just a template - -split n split_id root_id wanted - = go n - where - ty = linearInstType wanted - pair_ty = mkTyConApp pairTyCon [ty,ty] - id = instToId wanted - occ = getOccName id - loc = getSrcLoc id - span = instSpan wanted - - go 1 = returnM (emptyBag, [L span $ HsVar root_id]) - - go n = go ((n+1) `div` 2) `thenM` \ (binds1, rhss) -> - expand n rhss `thenM` \ (binds2, rhss') -> - returnM (binds1 `unionBags` binds2, rhss') - - -- (expand n rhss) - -- Given ((n+1)/2) rhss, make n rhss, using auxiliary bindings - -- e.g. expand 3 [rhs1, rhs2] - -- = ( { x = split rhs1 }, - -- [fst x, snd x, rhs2] ) - expand n rhss - | n `rem` 2 == 0 = go rhss -- n is even - | otherwise = go (tail rhss) `thenM` \ (binds', rhss') -> - returnM (binds', head rhss : rhss') - where - go rhss = mapAndUnzipM do_one rhss `thenM` \ (binds', rhss') -> - returnM (listToBag binds', concat rhss') - - do_one rhs = newUnique `thenM` \ uniq -> - tcLookupId fstName `thenM` \ fst_id -> - tcLookupId sndName `thenM` \ snd_id -> - let - x = mkUserLocal occ uniq pair_ty loc - in - returnM (L span (VarBind x (mk_app span split_id rhs)), - [mk_fs_app span fst_id ty x, mk_fs_app span snd_id ty x]) - -mk_fs_app span id ty var = nlHsTyApp id [ty,ty] `mkHsApp` (L span (HsVar var)) - -mk_app span id rhs = L span (HsApp (L span (HsVar id)) rhs) - addBind binds inst rhs = binds `unionBags` unitBag (L (instLocSrcSpan (instLoc inst)) (VarBind (instToId inst) rhs)) instSpan wanted = instLocSrcSpan (instLoc wanted) @@ -1759,11 +1671,7 @@ reduceList (n,stack) try_me wanteds state reduce stack try_me wanted avails -- It's the same as an existing inst, or a superclass thereof | Just avail <- isAvailable avails wanted - = if isLinearInst wanted then - addLinearAvailable avails avail wanted `thenM` \ (avails', wanteds') -> - reduceList stack try_me wanteds' avails' - else - returnM avails -- No op for non-linear things + = returnM avails | otherwise = case try_me wanted of { @@ -1814,32 +1722,6 @@ isAvailable avails wanted = lookupFM avails wanted -- *not* by unique. So -- d1::C Int == d2::C Int -addLinearAvailable :: Avails -> Avail -> Inst -> TcM (Avails, [Inst]) -addLinearAvailable avails avail wanted - -- avails currently maps [wanted -> avail] - -- Extend avails to reflect a neeed for an extra copy of avail - - | Just avail' <- split_avail avail - = returnM (addToFM avails wanted avail', []) - - | otherwise - = tcLookupId splitName `thenM` \ split_id -> - tcInstClassOp (instLoc wanted) split_id - [linearInstType wanted] `thenM` \ split_inst -> - returnM (addToFM avails wanted (Linear 2 split_inst avail), [split_inst]) - - where - split_avail :: Avail -> Maybe Avail - -- (Just av) if there's a modified version of avail that - -- we can use to replace avail in avails - -- Nothing if there isn't, so we need to create a Linear - split_avail (Linear n i a) = Just (Linear (n+1) i a) - split_avail (Given id used) | not used = Just (Given id True) - | otherwise = Nothing - split_avail Irred = Nothing - split_avail IsFree = Nothing - split_avail other = pprPanic "addLinearAvailable" (ppr avail $$ ppr wanted $$ ppr avails) - ------------------------- addFree :: Avails -> Inst -> TcM Avails -- When an Inst is tossed upstairs as 'free' we nevertheless add it @@ -1863,7 +1745,7 @@ addWanted want_scs avails wanted rhs_expr wanteds avail = Rhs rhs_expr wanteds addGiven :: Avails -> Inst -> TcM Avails -addGiven avails given = addAvailAndSCs AddSCs avails given (Given (instToId given) False) +addGiven avails given = addAvailAndSCs AddSCs avails given (Given (instToId given)) -- Always add superclasses for 'givens' -- -- No ASSERT( not (given `elemFM` avails) ) because in an instance @@ -1930,8 +1812,8 @@ addSCs is_loop avails dict is_given :: Inst -> Bool is_given sc_dict = case lookupFM avails sc_dict of - Just (Given _ _) -> True -- Given is cheaper than superclass selection - other -> False + Just (Given _) -> True -- Given is cheaper than superclass selection + other -> False \end{code} Note [SUPERCLASS-LOOP 2] diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 21375a9..cd4c4c7 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -68,7 +68,7 @@ module TcType ( isClassPred, isTyVarClassPred, isEqPred, mkDictTy, tcSplitPredTy_maybe, isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, - mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, + mkClassPred, isInheritablePred, isIPPred, mkPredName, dataConsStupidTheta, isRefineableTy, --------------------------------- @@ -186,7 +186,7 @@ import VarEnv ( TidyEnv ) import OccName ( OccName, mkDictOcc, mkOccName, tvName ) import PrelNames -- Lots (e.g. in isFFIArgumentTy) import TysWiredIn ( unitTyCon, charTyCon, listTyCon ) -import BasicTypes ( IPName(..), Arity, ipNameName ) +import BasicTypes ( Arity, ipNameName ) import SrcLoc ( SrcLoc, SrcSpan ) import Util ( equalLength ) import Maybes ( maybeToBool, expectJust, mapCatMaybes ) @@ -895,10 +895,6 @@ isInheritablePred :: PredType -> Bool -- which can be free in g's rhs, and shared by both calls to g isInheritablePred (ClassP _ _) = True isInheritablePred other = False - -isLinearPred :: TcPredType -> Bool -isLinearPred (IParam (Linear n) _) = True -isLinearPred other = False \end{code} --------------------- Equality predicates ---------------------------------