Commit bf40e268 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.
parent e6d05771
......@@ -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}
......
......@@ -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
......
......@@ -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 )
......
......@@ -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
......
......@@ -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 )
......
......@@ -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
......
......@@ -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 )
......
......@@ -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 )
......
......@@ -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`
......
......@@ -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 )
......
......@@ -250,7 +250,6 @@ $white_no_nl+ ;
<0,glaexts> {
\? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
\% @varid / { ifExtension ipEnabled } { skip_one_varid ITsplitipvarid }
}
<glaexts> {
......@@ -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
......
......@@ -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
......
......@@ -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 )
......
......@@ -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
......
......@@ -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}
......
......@@ -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]
......
%
%
% (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}
......
......@@ -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 )
......
......@@ -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)
-------------------------