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 (file)
--- 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}
 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)
 
   deriving( Eq, Ord )  -- Ord is used in the IP name cache finite map
                        --      (used in HscTypes.OrigIParamCache)
 

-

 ipNameName :: IPName name -> name
 ipNameName :: IPName name -> name

-ipNameName (Dupable n) = n
-ipNameName (Linear  n) = n
+ipNameName (IPName n) = n

 
 mapIPName :: (a->b) -> IPName a -> IPName b
 
 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
 
 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}
 
 
 \end{code}
 
 

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 394140d..406bf90 100644 (file)
--- 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,
                          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, 
                          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 )
 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) }
 
                ; 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
 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 (file)
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -24,7 +24,7 @@ module CoreSubst (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import CoreSyn         ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBind,
+import CoreSyn         ( Expr(..), Bind(..), CoreExpr, CoreBind,

                          CoreRule(..), hasUnfolding, noUnfolding
                        )
 import CoreFVs         ( exprFreeVars )
                          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 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 )
 import Outputable
 import PprCore         ()              -- Instances
 import Util            ( mapAccumL )

diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 3db1a33..65ad53c 100644 (file)
--- 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 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 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
 import BasicTypes      ( Activation )
 import FastString
 import Outputable

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 40866f4..2d111ee 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -18,8 +18,7 @@ import HsBinds                ( HsLocalBinds, DictBinds, isEmptyLocalBinds,
                          HsWrapper, pprHsWrapper )
 
 -- others:
                          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 )
 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 (file)
--- 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 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
 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
          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
 
 -------------------------------------------------------------------------
 --             Types from: Demand

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 077edb2..dfa8ba2 100644 (file)
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -15,9 +15,8 @@ module BuildTyCl (
 import IfaceEnv                ( newImplicitBinder )
 import TcRnMonad
 
 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 )
 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,
 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 ),
                          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, 
                          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(..), 
                          TyThing(..), 

-                         substTyWith, zipTopTvSubst, substTheta, mkForAllTys,
-                          mkTyConApp, mkTyVarTy )
+                         substTyWith, zipTopTvSubst, substTheta )

 import Coercion         ( mkNewTypeCoercion, mkDataInstCoercion )
 import Outputable
 import List            ( nub )
 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 (file)
--- 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 TysWiredIn      ( tupleTyCon, tupleCon )
 import HscTypes                ( NameCache(..), HscEnv(..), GenAvailInfo(..), 
                          IfaceExport, OrigNameCache )

-import Type            ( mkOpenTvSubst, substTy )

 import TyCon           ( TyCon, tyConName )
 import DataCon         ( dataConWorkId, dataConName )
 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 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 )
 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 (file)
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -36,22 +36,17 @@ import CoreSyn
 import IfaceType
 
 import NewDemand       ( StrictSig, pprIfaceStrictSig )
 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 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,
 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 Outputable
 import FastString

-import Maybes          ( catMaybes )
-import Util            ( lengthIs )

 
 infixl 3 &&&
 infix  4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
 
 infixl 3 &&&
 infix  4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`

diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
index 63e8985..70399e7 100644 (file)
--- a/compiler/iface/IfaceType.lhs
+++ b/compiler/iface/IfaceType.lhs
@@ -26,12 +26,10 @@ module IfaceType (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import Type            ( Kind )
-import Coercion         ( Coercion )

 import TypeRep         ( TyThing(..), Type(..), PredType(..), ThetaType,
                           unliftedTypeKindTyConName, openTypeKindTyConName,
                           ubxTupleKindTyConName, argTypeKindTyConName,
 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 )
 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 (file)
--- 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 }
 
 <0,glaexts> {
   \? @varid / { ifExtension ipEnabled }        { skip_one_varid ITdupipvarid }

-  \% @varid / { ifExtension ipEnabled } { skip_one_varid ITsplitipvarid }

 }
 
 <glaexts> {
 }
 
 <glaexts> {

@@ -442,7 +441,6 @@ data Token
   | ITqconsym (FastString,FastString)
 
   | ITdupipvarid   FastString  -- GHC extension: implicit param: ?x
   | ITqconsym (FastString,FastString)
 
   | ITdupipvarid   FastString  -- GHC extension: implicit param: ?x

-  | ITsplitipvarid FastString  -- GHC extension: implicit param: %x

 
   | ITpragma StringBuffer
 
 
   | ITpragma StringBuffer
 

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index c650a7c..0fd1b4d 100644 (file)
--- 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
  QCONSYM       { L _ (ITqconsym  _) }
 
  IPDUPVARID    { L _ (ITdupipvarid   _) }              -- GHC extension

- IPSPLITVARID          { L _ (ITsplitipvarid _) }              -- GHC extension

 
  CHAR          { L _ (ITchar     _) }
  STRING                { L _ (ITstring   _) }
 
  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) }
 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
 
 -----------------------------------------------------------------------------
 -- 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
 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
 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 (file)
--- 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 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 )
 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 (file)
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -192,9 +192,6 @@ basicKnownKeyNames
        -- MonadFix
        monadFixClassName, mfixName,
 
        -- MonadFix
        monadFixClassName, mfixName,
 

-       -- Splittable class
-       splittableClassName, splitName,
-

        -- Other classes
        randomClassName, randomGenClassName, monadPlusClassName,
 
        -- 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
 
 -- 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
 -- 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
 typeable7ClassKey      = mkPreludeClassUnique 27
 
 monadFixClassKey       = mkPreludeClassUnique 28

-splittableClassKey     = mkPreludeClassUnique 29

 
 monadPlusClassKey      = mkPreludeClassUnique 30
 randomClassKey         = mkPreludeClassUnique 31
 
 monadPlusClassKey      = mkPreludeClassUnique 30
 randomClassKey         = mkPreludeClassUnique 31

@@ -921,7 +913,6 @@ printIdKey                = mkPreludeMiscIdUnique 43
 failIOIdKey                  = mkPreludeMiscIdUnique 44
 nullAddrIdKey                = mkPreludeMiscIdUnique 46
 voidArgIdKey                 = mkPreludeMiscIdUnique 47
 failIOIdKey                  = mkPreludeMiscIdUnique 44
 nullAddrIdKey                = mkPreludeMiscIdUnique 46
 voidArgIdKey                 = mkPreludeMiscIdUnique 47

-splitIdKey                   = mkPreludeMiscIdUnique 48

 fstIdKey                     = mkPreludeMiscIdUnique 49
 sndIdKey                     = mkPreludeMiscIdUnique 50
 otherwiseIdKey               = mkPreludeMiscIdUnique 51
 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 (file)
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -28,7 +28,7 @@ module Inst (
        tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
 
        isDict, isClassDict, isMethod, 
        tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
 
        isDict, isClassDict, isMethod, 

-       isLinearInst, linearInstType, isIPDict, isInheritableInst,
+       isIPDict, isInheritableInst,

        isTyVarDict, isMethodFor, 
 
        zonkInst, zonkInsts,
        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,
                  isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
                  mkPredTy, mkTyVarTys,
                  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,

-                 isClassPred, isTyVarClassPred, isLinearPred, 
+                 isClassPred, isTyVarClassPred, 

                  getClassPredTys, mkPredName,
                  isInheritablePred, isIPPred, 
                  tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy, 
                  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
 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}
 
 
 \end{code}
 
 

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index e6ab82b..d9e25c3 100644 (file)
--- 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, 
                          mkTyVarTys, mkFunTys, 
                          tcMultiSplitSigmaTy, tcSplitFunTysN,
                          tcSplitTyConApp_maybe, 

-                         isSigmaTy, mkFunTy, mkTyConApp, isLinearPred,
+                         isSigmaTy, mkFunTy, mkTyConApp, 

                          exactTyVarsOfType, exactTyVarsOfTypes, 
                          zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar
                        )
                          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 }
 
        = do { co_fn <- instCall orig tys theta
             ; go False (HsWrap co_fn fun) prs }
 

-       --      Hack Alert (want_method_inst)!

        -- See Note [No method sharing]
        -- 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
                           && not opt_NoMethodSharing

-               -- See Note [No method sharing] below

 \end{code}
 
 Note [Multiple instantiation]
 \end{code}
 
 Note [Multiple instantiation]

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 9fa0d6b..026893c 100644 (file)
--- 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}
 % (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 :: (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}
 
 
 \end{code}
 
 

diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index b7b8bd2..ba1888d 100644 (file)
--- 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 )
                          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 )
                          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 )
 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 SrcLoc          ( SrcSpan, SrcLoc, Located, srcSpanStart )
 import VarSet          ( IdSet )
 import ErrUtils                ( Messages, Message )

-import UniqFM           ( UniqFM )

 import UniqSupply      ( UniqSupply )
 import BasicTypes      ( IPName )
 import Util            ( thenCmp )
 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 (file)
--- 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,
 
 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,
 
 import TcRnMonad
 import Inst            ( lookupInst, LookupInstResult(..),
                          tyVarsOfInst, fdPredsOfInsts,

-                         isDict, isClassDict, isLinearInst, linearInstType,
+                         isDict, isClassDict, 

                          isMethodFor, isMethod,
                          isMethodFor, isMethod,

-                         instToId, tyVarsOfInsts,  cloneDict,
+                         instToId, tyVarsOfInsts,  

                          ipNamesOfInsts, ipNamesOfInst, dictPred,
                          fdPredsOfInst, 
                          ipNamesOfInsts, ipNamesOfInst, dictPred,
                          fdPredsOfInst, 

-                         newDictBndrs, newDictBndrsO, tcInstClassOp,
+                         newDictBndrs, newDictBndrsO, 

                          getDictClassTys, isTyVarDict, instLoc,
                          zonkInst, tidyInsts, tidyMoreInsts,
                          pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs,
                          isInheritableInst, pprDictsTheta
                        )
                          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,
                          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 )
                          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 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 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 )
                          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
 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
 
   | 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
 
 
   | 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 ]
 
 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 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 (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.
 \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 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
                               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
 
                             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
 
     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!
 
        --   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)
 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
 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 {
 
   | 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
 
        --  *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
 -------------------------
 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
     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
        -- 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
 
     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]
 \end{code}
 
 Note [SUPERCLASS-LOOP 2]

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 21375a9..cd4c4c7 100644 (file)
--- 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, 
   isClassPred, isTyVarClassPred, isEqPred, 
   mkDictTy, tcSplitPredTy_maybe, 
   isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, 

-  mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, 
+  mkClassPred, isInheritablePred, isIPPred, mkPredName, 

   dataConsStupidTheta, isRefineableTy,
 
   ---------------------------------
   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 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 )
 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
 -- 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 ---------------------------------
 \end{code}
 
 --------------------- Equality predicates ---------------------------------