Fixity(..), FixityDirection(..),
defaultFixity, maxPrecedence, negateFixity, negatePrecedence,
+ IPName(..), ipNameName, mapIPName,
+
NewOrData(..),
RecFlag(..), isRec, isNonRec,
%************************************************************************
%* *
+\subsection{Implicit parameter identity}
+%* *
+%************************************************************************
+
+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
+ 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
+
+mapIPName :: (a->b) -> IPName a -> IPName b
+mapIPName f (Dupable n) = Dupable (f n)
+mapIPName f (Linear n) = Linear (f n)
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection[Fixity]{Fixity info}
%* *
%************************************************************************
import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
import DataCon ( isExistentialDataCon )
import Literal ( Literal(..) )
-import Type ( ipNameName )
import TyCon ( tyConDataCons )
import TysWiredIn ( tupleCon, listTyCon, charDataCon, intDataCon )
-import BasicTypes ( RecFlag(..), Boxity(..) )
+import BasicTypes ( RecFlag(..), Boxity(..), ipNameName )
import Maybes ( maybeToBool )
import PrelNames ( hasKey, ratioTyConKey )
import Util ( zipEqual, zipWithEqual )
import ForeignCall ( Safety )
import Outputable
import PprType ( pprParendType )
-import Type ( Type, IPName )
+import Type ( Type )
import Var ( TyVar )
import DataCon ( DataCon )
import CStrings ( CLabelString, pprCLabelString )
-import BasicTypes ( Boxity, tupleParens )
+import BasicTypes ( IPName, Boxity, tupleParens )
import SrcLoc ( SrcLoc )
\end{code}
#include "HsVersions.h"
import Class ( FunDep )
-import TcType ( Type, Kind, ThetaType, SourceType(..), IPName,
+import TcType ( Type, Kind, ThetaType, SourceType(..),
tcSplitSigmaTy, liftedTypeKind, eqKind, tcEqType
)
import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation
import Var ( TyVar, tyVarKind )
import Subst ( substTyWith )
import PprType ( {- instance Outputable Kind -}, pprParendKind )
-import BasicTypes ( Boxity(..), Arity, tupleParens )
+import BasicTypes ( Boxity(..), Arity, IPName, tupleParens )
import PrelNames ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey, hasKey,
usOnceTyConName, usManyTyConName
)
import Rules ( RuleBase )
import CoreSyn ( CoreBind )
import Id ( Id )
-import Type ( IPName )
import Class ( Class, classSelIds )
import TyCon ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable )
import DataCon ( dataConId, dataConWrapId )
-import BasicTypes ( Version, initialVersion, Fixity )
+import BasicTypes ( Version, initialVersion, Fixity, IPName )
import HsSyn ( DeprecTxt, tyClDeclName, ifaceRuleDeclName )
import RdrHsSyn ( RdrNameInstDecl, RdrNameRuleDecl, RdrNameTyClDecl )
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.78 2001/11/26 10:30:15 simonpj Exp $
+$Id: Parser.y,v 1.79 2001/11/29 13:47:10 simonpj Exp $
Haskell grammar.
import HsSyn
import HsTypes ( mkHsTupCon )
-import TypeRep ( IPName(..) )
import RdrHsSyn
import Lex
import SrcLoc ( SrcLoc )
import Module
import CmdLineOpts ( opt_SccProfilingOn )
-import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..),
+import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
NewOrData(..), StrictnessMark(..), Activation(..) )
import Panic
-- *after* we see the close paren.
ipvar :: { IPName RdrName }
- : IPDUPVARID { Dupable (mkUnqual varName $1) }
- | IPSPLITVARID { MustSplit (mkUnqual varName $1) }
+ : IPDUPVARID { Dupable (mkUnqual varName $1) }
+ | IPSPLITVARID { Linear (mkUnqual varName $1) }
qcon :: { RdrName }
: qconid { $1 }
knownKeyNames
= [
-- Type constructors (synonyms especially)
- ioTyConName,
+ ioTyConName, ioDataConName,
mainName,
orderingTyConName,
rationalTyConName,
eqStringName,
assertName,
runSTRepName,
- printName
+ printName,
+ splitIdName, fstIdName, sndIdName -- Used by splittery
]
\end{code}
pREL_BYTEARR_Name = mkModuleName "PrelByteArr"
pREL_FOREIGN_Name = mkModuleName "PrelForeign"
pREL_STABLE_Name = mkModuleName "PrelStable"
+pREL_SPLIT_Name = mkModuleName "PrelSplit"
pREL_ADDR_Name = mkModuleName "PrelAddr"
pREL_PTR_Name = mkModuleName "PrelPtr"
pREL_ERR_Name = mkModuleName "PrelErr"
fOREIGNOBJ_Name = mkModuleName "ForeignObj"
aDDR_Name = mkModuleName "Addr"
+gLA_EXTS_Name = mkModuleName "GlaExts"
+
pREL_GHC = mkPrelModule pREL_GHC_Name
pREL_BASE = mkPrelModule pREL_BASE_Name
pREL_ADDR = mkPrelModule pREL_ADDR_Name
nilDataConName = dataQual pREL_BASE_Name SLIT("[]") nilDataConKey
consDataConName = dataQual pREL_BASE_Name SLIT(":") consDataConKey
+-- PrelTup
+fstIdName = varQual pREL_TUP_Name SLIT("fst") fstIdKey
+sndIdName = varQual pREL_TUP_Name SLIT("snd") sndIdKey
+
-- Generics
crossTyConName = tcQual pREL_BASE_Name SLIT(":*:") crossTyConKey
crossDataConName = dataQual pREL_BASE_Name SLIT(":*:") crossDataConKey
assertName = varQual pREL_GHC_Name SLIT("assert") assertIdKey
getTagName = varQual pREL_GHC_Name SLIT("getTag#") getTagIdKey
runSTRepName = varQual pREL_ST_Name SLIT("runSTRep") runSTRepIdKey
+
+-- The "split" Id for splittable implicit parameters
+splitIdName = varQual pREL_SPLIT_Name SLIT("split") splitIdKey
\end{code}
%************************************************************************
unpackCStringListIdKey = mkPreludeMiscIdUnique 45
nullAddrIdKey = mkPreludeMiscIdUnique 46
voidArgIdKey = mkPreludeMiscIdUnique 47
+splitIdKey = mkPreludeMiscIdUnique 48
+fstIdKey = mkPreludeMiscIdUnique 49
+sndIdKey = mkPreludeMiscIdUnique 50
\end{code}
Certain class operations from Prelude classes. They get their own
import Literal ( Literal(..), mkMachInt, mkMachInt64, mkMachWord, mkMachWord64 )
import BasicTypes ( Fixity(..), FixityDirection(..), StrictnessMark(..),
NewOrData(..), Version, initialVersion, Boxity(..),
- Activation(..)
+ Activation(..), IPName(..)
)
import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
import Type ( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind )
-import TypeRep ( IPName(..) )
import ForeignCall ( ForeignCall(..), CCallConv(..), CCallSpec(..), CCallTarget(..) )
import Lex
| QVARID { mkIfaceOrig varName $1 }
ipvar_name :: { IPName RdrName }
- : IPDUPVARID { Dupable (mkRdrUnqual (mkSysOccFS varName $1)) }
- | IPSPLITVARID { MustSplit (mkRdrUnqual (mkSysOccFS varName $1)) }
+ : IPDUPVARID { Dupable (mkRdrUnqual (mkSysOccFS varName $1)) }
+ | IPSPLITVARID { Linear (mkRdrUnqual (mkSysOccFS varName $1)) }
qvar_names1 :: { [RdrName] }
qvar_names1 : qvar_name { [$1] }
Deprecations(..), lookupDeprec,
extendLocalRdrEnv
)
-import Type ( mapIPName )
import RnMonad
import Name ( Name,
getSrcLoc, nameIsLocalOrFrom,
import Outputable
import ListSetOps ( removeDups, equivClasses )
import Util ( sortLt )
+import BasicTypes ( mapIPName )
import List ( nub )
import UniqFM ( lookupWithDefaultUFM )
import CmdLineOpts
import RnHiFiles ( lookupFixityRn )
import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
import Literal ( inIntRange, inCharRange )
-import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
+import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..), defaultFixity, negateFixity )
import PrelNames ( hasKey, assertIdKey,
- eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR,
- cCallableClass_RDR, cReturnableClass_RDR,
- monadClass_RDR, enumClass_RDR, ordClass_RDR,
- ratioDataCon_RDR, assertErr_RDR,
- ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR,
+ eqClassName, foldrName, buildName, eqStringName,
+ cCallableClassName, cReturnableClassName,
+ monadClassName, enumClassName, ordClassName,
+ ratioDataConName, splitIdName, fstIdName, sndIdName,
+ ioDataConName, plusIntegerName, timesIntegerName,
+ assertErr_RDR
)
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon
doc = text "a pattern type-signature"
rnPat (LitPatIn s@(HsString _))
- = lookupOrigName eqString_RDR `thenRn` \ eq ->
- returnRn (LitPatIn s, unitFV eq)
+ = returnRn (LitPatIn s, unitFV eqStringName)
rnPat (LitPatIn lit)
= litFVs lit `thenRn` \ fvs ->
rnPat (NPatIn lit)
= rnOverLit lit `thenRn` \ (lit', fvs1) ->
- lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern
- returnRn (NPatIn lit', fvs1 `addOneFV` eq)
+ returnRn (NPatIn lit', fvs1 `addOneFV` eqClassName) -- Needed to find equality on pattern
rnPat (NPlusKPatIn name lit minus)
= rnOverLit lit `thenRn` \ (lit', fvs) ->
- lookupOrigName ordClass_RDR `thenRn` \ ord ->
lookupBndrRn name `thenRn` \ name' ->
lookupSyntaxName minus `thenRn` \ minus' ->
- returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ord `addOneFV` minus')
+ returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ordClassName `addOneFV` minus')
rnPat (LazyPatIn pat)
= rnPat pat `thenRn` \ (pat', fvs) ->
rnExpr (HsIPVar v)
= newIPName v `thenRn` \ name ->
- returnRn (HsIPVar name, emptyFVs)
+ let
+ fvs = case name of
+ Linear _ -> mkFVs [splitIdName, fstIdName, sndIdName]
+ Dupable _ -> emptyFVs
+ in
+ returnRn (HsIPVar name, fvs)
rnExpr (HsLit lit)
= litFVs lit `thenRn` \ fvs ->
rnExpr (HsCCall fun args may_gc is_casm _)
-- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
- = lookupOrigNames [cCallableClass_RDR,
- cReturnableClass_RDR,
- ioDataCon_RDR] `thenRn` \ implicit_fvs ->
+ = lookupOrigNames [] `thenRn` \ implicit_fvs ->
rnExprs args `thenRn` \ (args', fvs_args) ->
returnRn (HsCCall fun args' may_gc is_casm placeHolderType,
- fvs_args `plusFV` implicit_fvs)
+ fvs_args `plusFV` mkFVs [cCallableClassName,
+ cReturnableClassName,
+ ioDataConName])
rnExpr (HsSCC lbl expr)
= rnExpr expr `thenRn` \ (expr', fvs_expr) ->
rnExpr e@(HsDo do_or_lc stmts src_loc)
= pushSrcLocRn src_loc $
- lookupOrigNames implicit_rdr_names `thenRn` \ implicit_fvs ->
rnStmts stmts `thenRn` \ ((_, stmts'), fvs) ->
-- check the statement list ends in an expression
case last stmts' of {
} `thenRn_`
returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
where
- implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR]
+ implicit_fvs = mkFVs [foldrName, buildName, monadClassName]
-- Monad stuff should not be necessary for a list comprehension
-- but the typechecker looks up the bind and return Ids anyway
-- Oh well.
doc = text "renaming a type pattern"
rnExpr (ArithSeqIn seq)
- = lookupOrigName enumClass_RDR `thenRn` \ enum ->
- rn_seq seq `thenRn` \ (new_seq, fvs) ->
- returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum)
+ = rn_seq seq `thenRn` \ (new_seq, fvs) ->
+ returnRn (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
where
rn_seq (From expr)
= rnExpr expr `thenRn` \ (expr', fvExpr) ->
litFVs (HsIntPrim i) = returnRn (unitFV (getName intPrimTyCon))
litFVs (HsFloatPrim f) = returnRn (unitFV (getName floatPrimTyCon))
litFVs (HsDoublePrim d) = returnRn (unitFV (getName doublePrimTyCon))
-litFVs (HsLitLit l bogus_ty) = lookupOrigName cCallableClass_RDR `thenRn` \ cc ->
- returnRn (unitFV cc)
+litFVs (HsLitLit l bogus_ty) = returnRn (unitFV cCallableClassName)
litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear
-- in post-typechecker translations
= lookupSyntaxName from_integer_name `thenRn` \ from_integer_name' ->
if inIntRange i then
returnRn (HsIntegral i from_integer_name', unitFV from_integer_name')
- else
- lookupOrigNames [plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns ->
+ else let
+ fvs = mkFVs [plusIntegerName, timesIntegerName]
-- Big integer literals are built, using + and *,
-- out of small integers (DsUtils.mkIntegerLit)
-- [NB: plusInteger, timesInteger aren't rebindable...
-- they are used to construct the argument to fromInteger,
-- which is the rebindable one.]
- returnRn (HsIntegral i from_integer_name', ns `addOneFV` from_integer_name')
+ in
+ returnRn (HsIntegral i from_integer_name', fvs `addOneFV` from_integer_name')
rnOverLit (HsFractional i from_rat_name)
= lookupSyntaxName from_rat_name `thenRn` \ from_rat_name' ->
- lookupOrigNames [ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns ->
+ let
+ fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
-- We have to make sure that the Ratio type is imported with
-- its constructor, because literals of type Ratio t are
-- built with that constructor.
-- when fractionalClass does.
-- The plus/times integer operations may be needed to construct the numerator
-- and denominator (see DsUtils.mkIntegerLit)
- returnRn (HsFractional i from_rat_name', ns `addOneFV` from_rat_name')
+ in
+ returnRn (HsFractional i from_rat_name', fvs `addOneFV` from_rat_name')
\end{code}
%************************************************************************
new_version_map = extendNameEnv version_map main_name version
in
+ traceRn (text "Loading" <+> ppr full_avail) `thenRn_`
returnRn (new_version_map, new_decls_map)
-----------------------------------------------------
import Name ( Name, NamedThing(..) )
import NameSet
import PrelInfo ( derivableClassKeys )
-import PrelNames ( deRefStablePtr_RDR, newStablePtr_RDR,
- bindIO_RDR, returnIO_RDR
+import PrelNames ( deRefStablePtrName, newStablePtrName,
+ bindIOName, returnIOName
)
import TysWiredIn ( tupleCon )
import List ( partition )
rnHsForeignDecl (ForeignImport name ty spec src_loc)
= pushSrcLocRn src_loc $
lookupTopBndrRn name `thenRn` \ name' ->
- rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) ->
- lookupOrigNames (extras spec) `thenRn` \ fvs2 ->
- returnRn (ForeignImport name' ty' spec src_loc, fvs1 `plusFV` fvs2)
+ rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs) ->
+ returnRn (ForeignImport name' ty' spec src_loc, fvs `plusFV` extras spec)
where
- extras (CDynImport _) = [newStablePtr_RDR, deRefStablePtr_RDR, bindIO_RDR, returnIO_RDR]
- extras other = []
+ extras (CDynImport _) = mkFVs [newStablePtrName, deRefStablePtrName, bindIOName, returnIOName]
+ extras other = emptyFVs
rnHsForeignDecl (ForeignExport name ty spec src_loc)
= pushSrcLocRn src_loc $
lookupOccRn name `thenRn` \ name' ->
- rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) ->
- lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs2 ->
- returnRn (ForeignExport name' ty' spec src_loc, fvs1 `plusFV` fvs2)
+ rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs) ->
+ returnRn (ForeignExport name' ty' spec src_loc,
+ mkFVs [bindIOName, returnIOName] `plusFV` fvs)
fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name
\end{code}
Inst,
pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts,
- newDictsFromOld, newDicts,
- newMethod, newMethodWithGivenTy, newOverloadedLit,
- newIPDict, tcInstId,
+ newDictsFromOld, newDicts, cloneDict,
+ newMethod, newMethodWithGivenTy, newMethodAtLoc,
+ newOverloadedLit, newIPDict, tcInstId,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, predsOfInst, predsOfInsts,
lookupInst, lookupSimpleInst, LookupInstResult(..),
- isDict, isClassDict, isMethod,
+ isDict, isClassDict, isMethod, isLinearInst, linearInstType,
isTyVarDict, isStdClassTyVarDict, isMethodFor,
instBindingRequired, instCanBeGeneralised,
isClassPred, isTyVarClassPred,
getClassPredTys, getClassPredTys_maybe, mkPredName,
tidyType, tidyTypes, tidyFreeTyVars,
- tcCmpType, tcCmpTypes, tcCmpPred,
- IPName, mapIPName, ipNameName
+ tcCmpType, tcCmpTypes, tcCmpPred
)
import CoreFVs ( idFreeTyVars )
import Class ( Class )
-import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId )
+import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName )
import PprType ( pprPred )
import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames( fromIntegerName, fromRationalName )
import Util ( thenCmp, equalLength )
+import BasicTypes( IPName(..), mapIPName, ipNameName )
+
import Bag
import Outputable
\end{code}
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 Inst.tcInstId
+
+isLinearPred :: TcPredType -> Bool
+isLinearPred (IParam (Linear n) _) = True
+isLinearPred other = False
+
+linearInstType :: Inst -> TcType -- %x::t --> t
+linearInstType (Dict _ (IParam _ ty) _) = ty
+
+
isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
other -> False
= tcGetInstLoc orig `thenNF_Tc` \ loc ->
newDictsAtLoc loc theta
+cloneDict :: Inst -> NF_TcM Inst
+cloneDict (Dict id ty loc) = tcGetUnique `thenNF_Tc` \ uniq ->
+ returnNF_Tc (Dict (setIdUnique id uniq) ty loc)
+
newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst]
newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
\begin{code}
tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
tcInstId fun
- | opt_NoMethodSharing = loop_noshare (HsVar fun) (idType fun)
- | otherwise = loop_share fun
+ = loop (HsVar fun) emptyLIE (idType fun)
where
orig = OccurrenceOf fun
- loop_noshare fun fun_ty
- = tcInstType fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
- let
- ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
- in
- if null theta then -- Is it overloaded?
- returnNF_Tc (ty_app, emptyLIE, tau)
- else
- newDicts orig theta `thenNF_Tc` \ dicts ->
- loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau `thenNF_Tc` \ (expr, lie, final_tau) ->
- returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
-
- loop_share fun
- = tcInstType (idType fun) `thenNF_Tc` \ (tyvars, theta, tau) ->
- let
- arg_tys = mkTyVarTys tyvars
- in
- if null theta then -- Is it overloaded?
- returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
- else
- -- Yes, it's overloaded
- newMethodWithGivenTy orig fun arg_tys theta tau `thenNF_Tc` \ meth ->
- loop_share (instToId meth) `thenNF_Tc` \ (expr, lie, final_tau) ->
- returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
-
+ loop fun lie fun_ty = tcInstType fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
+ loop_help fun lie (mkTyVarTys tyvars) theta tau
+
+ loop_help fun lie arg_tys [] tau -- Not overloaded
+ = returnNF_Tc (mkHsTyApp fun arg_tys, lie, tau)
+
+ loop_help (HsVar fun_id) lie arg_tys theta tau
+ | can_share theta -- Sharable method binding
+ = newMethodWithGivenTy orig fun_id arg_tys theta tau `thenNF_Tc` \ meth ->
+ loop (HsVar (instToId meth))
+ (unitLIE meth `plusLIE` lie) tau
+
+ loop_help fun lie arg_tys theta tau -- The general case
+ = newDicts orig theta `thenNF_Tc` \ dicts ->
+ loop (mkHsDictApp (mkHsTyApp fun arg_tys) (map instToId dicts))
+ (mkLIE dicts `plusLIE` lie) tau
+
+ can_share theta | opt_NoMethodSharing = False
+ | otherwise = not (any isLinearPred theta)
+ -- This is a slight hack.
+ -- 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.
newMethod :: InstOrigin
-> TcId
import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId )
import TcMonad
-import TypeRep ( IPName(..) ) -- For zonking
-import Type ( Type, ipNameName )
+import Type ( Type )
import TcType ( TcType )
import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars )
import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
mkListTy, mkTupleTy, unitTy )
import CoreSyn ( Expr )
import Var ( isId )
-import BasicTypes ( RecFlag(..), Boxity(..) )
+import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName )
import Bag
import Outputable
import HscTypes ( TyThing(..) )
-------------------------------------------------------------------------
mapIPNameTc :: (a -> NF_TcM b) -> IPName a -> NF_TcM (IPName b)
-mapIPNameTc f (Dupable n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Dupable r)
-mapIPNameTc f (MustSplit n) = f n `thenNF_Tc` \ r -> returnNF_Tc (MustSplit r)
+mapIPNameTc f (Dupable n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Dupable r)
+mapIPNameTc f (Linear n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Linear r)
\end{code}
import HsLit ( HsOverLit )
import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
-import TcType ( Type, Kind, TyVarDetails, IPName )
+import TcType ( Type, Kind, TyVarDetails )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
import Bag ( Bag, emptyBag, isEmptyBag,
splitUniqSupply, mkSplitUniqSupply,
UniqSM, initUs_ )
import SrcLoc ( SrcLoc, noSrcLoc )
+import BasicTypes ( IPName )
import UniqFM ( emptyUFM )
import Unique ( Unique )
import CmdLineOpts
import TcMonad
import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
tyVarsOfInst, predsOfInsts, predsOfInst,
- isDict, isClassDict,
- isStdClassTyVarDict, isMethodFor,
- instToId, tyVarsOfInsts,
+ isDict, isClassDict, isLinearInst, linearInstType,
+ isStdClassTyVarDict, isMethodFor, isMethod,
+ instToId, tyVarsOfInsts, cloneDict,
ipNamesOfInsts, ipNamesOfInst,
instBindingRequired, instCanBeGeneralised,
- newDictsFromOld,
+ newDictsFromOld, newMethodAtLoc,
getDictClassTys, isTyVarDict,
instLoc, pprInst, zonkInst, tidyInsts, tidyMoreInsts,
Inst, LIE, pprInsts, pprInstsInFull,
mkLIE, lieToList
)
-import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv )
+import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv, tcLookupGlobalId )
import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars )
import TcType ( TcTyVar, TcTyVarSet, ThetaType, PredType,
- mkClassPred, isOverloadedTy,
+ mkClassPred, isOverloadedTy, mkTyConApp,
mkTyVarTy, tcGetTyVar, isTyVarClassPred,
tyVarsOfPred, getClassPredTys_maybe, isClassPred, isIPPred,
inheritablePred, predHasFDs )
-import Id ( idType )
+import Id ( idType, mkUserLocal )
+import Name ( getOccName, getSrcLoc )
import NameSet ( NameSet, mkNameSet, elemNameSet )
import Class ( classBigSig )
import FunDeps ( oclose, grow, improve, pprEquationDoc )
-import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
+import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass,
+ splitIdName, fstIdName, sndIdName )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
-import TysWiredIn ( unitTy )
+import TysWiredIn ( unitTy, pairTyCon )
import VarSet
import FiniteMap
import Outputable
\begin{code}
-type RedState = (Avails, -- What's available
- [Inst]) -- Insts for which try_me returned Free
-
type Avails = FiniteMap Inst Avail
data Avail
- = Irred -- Used for irreducible dictionaries,
+ = IsFree -- Used for free Insts
+ | Irred -- Used for irreducible dictionaries,
-- which are going to be lambda bound
- | BoundTo TcId -- Used for dictionaries for which we have a binding
+ | 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)
| NoRhs -- Used for Insts like (CCallable f)
-- where no witness is required.
TcExpr -- 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
+ [TcExpr] -- A supply of suitable RHSs
+
pprAvails avails = vcat [ppr inst <+> equals <+> pprAvail avail
| (inst,avail) <- fmToList avails ]
instance Outputable Avail where
ppr = pprAvail
-pprAvail NoRhs = text "<no rhs>"
-pprAvail Irred = text "Irred"
-pprAvail (BoundTo x) = text "Bound to" <+> ppr x
-pprAvail (Rhs rhs bs) = ppr rhs <+> braces (ppr bs)
+pprAvail NoRhs = text "<no rhs>"
+pprAvail IsFree = text "Free"
+pprAvail Irred = text "Irred"
+pprAvail (Given x b) = text "Given" <+> ppr x <+>
+ if b then text "(used)" else empty
+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.
The loop startes
\begin{code}
-bindsAndIrreds :: Avails
+extractResults :: Avails
-> [Inst] -- Wanted
- -> (TcDictBinds, -- Bindings
- [Inst]) -- Irreducible ones
+ -> NF_TcM (TcDictBinds, -- Bindings
+ [Inst], -- Irreducible ones
+ [Inst]) -- Free ones
-bindsAndIrreds avails wanteds
- = go avails EmptyMonoBinds [] wanteds
+extractResults avails wanteds
+ = go avails EmptyMonoBinds [] [] wanteds
where
- go avails binds irreds [] = (binds, irreds)
+ go avails binds irreds frees []
+ = returnNF_Tc (binds, irreds, frees)
- go avails binds irreds (w:ws)
+ go avails binds irreds frees (w:ws)
= case lookupFM avails w of
- Nothing -> -- Free guys come out here
- -- (If we didn't do addFree we could use this as the
- -- criterion for free-ness, and pick up the free ones here too)
- go avails binds irreds ws
+ Nothing -> pprTrace "Urk: extractResults" (ppr w) $
+ go avails binds irreds frees ws
- Just NoRhs -> go avails binds irreds ws
+ Just NoRhs -> go avails binds 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 Irred -> go (addToFM avails w (BoundTo (instToId w))) binds (w:irreds) ws
-
- Just (BoundTo id) -> go avails new_binds irreds ws
+ Just (Given id _) -> go avails new_binds irreds frees ws
where
- -- For implicit parameters, all occurrences share the same
- -- Id, so there is no need for synonym bindings
- -- ** BUT THIS TEST IS NEEDED FOR DICTS TOO ** (not sure why)
- new_binds | new_id == id = binds
- | otherwise = addBind binds new_id (HsVar id)
- new_id = instToId w
-
- Just (Rhs rhs ws') -> go avails' (addBind binds id rhs) irreds (ws' ++ ws)
- where
- id = instToId w
- avails' = addToFM avails w (BoundTo id)
+ new_binds | id == instToId w = binds
+ | otherwise = addBind binds w (HsVar id)
+ -- The sought Id can be one of the givens, via a superclass chain
+ -- and then we definitely don't want to generate an x=x binding!
-addBind binds id rhs = binds `AndMonoBinds` VarMonoBind id rhs
+ Just (Rhs rhs ws') -> go (add_given avails w) new_binds irreds frees (ws' ++ ws)
+ where
+ new_binds = addBind binds w rhs
+
+ 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)
+
+ Just (Linear n split_inst avail)
+ -> split n (instToId split_inst) avail w `thenNF_Tc` \ (binds', (rhs:rhss), irreds') ->
+ go (addToFM avails w (LinRhss rhss))
+ (binds `AndMonoBinds` addBind binds' w rhs)
+ (irreds' ++ irreds) frees (split_inst:ws)
+
+
+ add_given avails w
+ | instBindingRequired w = addToFM avails w (Given (instToId w) True)
+ | otherwise = addToFM avails w NoRhs
+ -- NB: make sure that CCallable/CReturnable use NoRhs rather
+ -- than Given, else we end up with bogus bindings.
+
+ add_free avails w | isMethod w = avails
+ | otherwise = add_given avails w
+ -- NB: Hack alert!
+ -- Do *not* replace Free by Given if it's a method.
+ -- The following situation shows why this is bad:
+ -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
+ -- From an application (truncate f i) we get
+ -- t1 = truncate at f
+ -- t2 = t1 at i
+ -- If we have also have a second occurrence of truncate, we get
+ -- t3 = truncate at f
+ -- t4 = t3 at i
+ -- When simplifying with i,f free, we might still notice that
+ -- t1=t3; but alas, the binding for t2 (which mentions t1)
+ -- will continue to float out!
+ -- (split n i a) returns: n rhss
+ -- auxiliary bindings
+ -- 1 or 0 insts to add to irreds
+
+
+split :: Int -> TcId -> Avail -> Inst
+ -> NF_TcM (TcDictBinds, [TcExpr], [Inst])
+-- (split n split_id avail 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)
+split n split_id avail wanted
+ = go n
+ where
+ ty = linearInstType wanted
+ pair_ty = mkTyConApp pairTyCon [ty,ty]
+ id = instToId wanted
+ occ = getOccName id
+ loc = getSrcLoc id
+
+ go 1 = case avail of
+ Given id _ -> returnNF_Tc (EmptyMonoBinds, [HsVar id], [])
+ Irred -> cloneDict wanted `thenNF_Tc` \ w' ->
+ returnNF_Tc (EmptyMonoBinds, [HsVar (instToId w')], [w'])
+
+ go n = go ((n+1) `div` 2) `thenNF_Tc` \ (binds1, rhss, irred) ->
+ expand n rhss `thenNF_Tc` \ (binds2, rhss') ->
+ returnNF_Tc (binds1 `AndMonoBinds` binds2, rhss', irred)
+
+ -- (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) `thenNF_Tc` \ (binds', rhss') ->
+ returnNF_Tc (binds', head rhss : rhss')
+ where
+ go rhss = mapAndUnzipNF_Tc do_one rhss `thenNF_Tc` \ (binds', rhss') ->
+ returnNF_Tc (andMonoBindList binds', concat rhss')
+
+ do_one rhs = tcGetUnique `thenNF_Tc` \ uniq ->
+ tcLookupGlobalId fstIdName `thenNF_Tc` \ fst_id ->
+ tcLookupGlobalId sndIdName `thenNF_Tc` \ snd_id ->
+ let
+ x = mkUserLocal occ uniq pair_ty loc
+ in
+ returnNF_Tc (VarMonoBind x (mk_app split_id rhs),
+ [mk_fs_app fst_id ty x, mk_fs_app snd_id ty x])
+
+mk_fs_app id ty var = HsVar id `TyApp` [ty,ty] `HsApp` HsVar var
+
+mk_app id rhs = HsApp (HsVar id) rhs
+
+addBind binds inst rhs = binds `AndMonoBinds` VarMonoBind (instToId inst) rhs
\end{code}
])) `thenNF_Tc_`
-- Build the Avail mapping from "givens"
- foldlNF_Tc addGiven (emptyFM, []) givens `thenNF_Tc` \ init_state ->
+ foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ init_state ->
-- Do the real work
- reduceList (0,[]) try_me wanteds init_state `thenNF_Tc` \ state@(avails, frees) ->
+ reduceList (0,[]) try_me wanteds init_state `thenNF_Tc` \ avails ->
-- Do improvement, using everything in avails
-- In particular, avails includes all superclasses of everything
tcImprove avails `thenTc` \ no_improvement ->
+ extractResults avails wanteds `thenNF_Tc` \ (binds, irreds, frees) ->
+
traceTc (text "reduceContext end" <+> (vcat [
text "----------------------",
doc,
text "no_improvement =" <+> ppr no_improvement,
text "----------------------"
])) `thenNF_Tc_`
- let
- (binds, irreds) = bindsAndIrreds avails wanteds
- in
- returnTc (no_improvement, frees, binds, irreds)
+
+ returnTc (no_improvement, frees, binds, irreds)
tcImprove avails
= tcGetInstEnv `thenTc` \ inst_env ->
-- along with its depth
-> (Inst -> WhatToDo)
-> [Inst]
- -> RedState
- -> TcM RedState
+ -> Avails
+ -> TcM Avails
\end{code}
@reduce@ is passed
Free return this in "frees"
wanteds: The list of insts to reduce
- state: An accumulating parameter of type RedState
+ state: An accumulating parameter of type Avails
that contains the state of the algorithm
- It returns a RedState.
+ It returns a Avails.
The (n,stack) pair is just used for error reporting.
n is always the depth of the stack.
-- Base case: we're done!
reduce stack try_me wanted state
-- It's the same as an existing inst, or a superclass thereof
- | isAvailable state wanted
- = returnTc state
+ | Just avail <- isAvailable state wanted
+ = if isLinearInst wanted then
+ addLinearAvailable state avail wanted `thenNF_Tc` \ (state', wanteds') ->
+ reduceList stack try_me wanteds' state'
+ else
+ returnTc state -- No op for non-linear things
| otherwise
= case try_me wanted of {
\begin{code}
-isAvailable :: RedState -> Inst -> Bool
-isAvailable (avails, _) wanted = wanted `elemFM` avails
- -- NB: the Ord instance of Inst compares by the class/type info
+-------------------------
+isAvailable :: Avails -> Inst -> Maybe Avail
+isAvailable avails wanted = lookupFM avails wanted
+ -- NB 1: the Ord instance of Inst compares by the class/type info
-- *not* by unique. So
-- d1::C Int == d2::C Int
+addLinearAvailable :: Avails -> Avail -> Inst -> NF_TcM (Avails, [Inst])
+addLinearAvailable avails avail wanted
+ | need_split avail
+ = tcLookupGlobalId splitIdName `thenNF_Tc` \ split_id ->
+ newMethodAtLoc (instLoc wanted) split_id
+ [linearInstType wanted] `thenNF_Tc` \ (split_inst,_) ->
+ returnNF_Tc (addToFM avails wanted (Linear 2 split_inst avail), [split_inst])
+
+ | otherwise
+ = returnNF_Tc (addToFM avails wanted avail', [])
+ where
+ avail' = case avail of
+ Given id _ -> Given id True
+ Linear n i a -> Linear (n+1) i a
+
+ need_split Irred = True
+ need_split (Given _ used) = used
+ need_split (Linear _ _ _) = False
+
-------------------------
-addFree :: RedState -> Inst -> NF_TcM RedState
+addFree :: Avails -> Inst -> NF_TcM Avails
-- When an Inst is tossed upstairs as 'free' we nevertheless add it
-- to avails, so that any other equal Insts will be commoned up right
-- here rather than also being tossed upstairs. This is really just
-- but a is not bound here, then we *don't* want to derive
-- dn from df here lest we lose sharing.
--
- -- NB2: do *not* add the Inst to avails at all if it's a method.
- -- The following situation shows why this is bad:
- -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
- -- From an application (truncate f i) we get
- -- t1 = truncate at f
- -- t2 = t1 at i
- -- If we have also have a second occurrence of truncate, we get
- -- t3 = truncate at f
- -- t4 = t3 at i
- -- When simplifying with i,f free, we might still notice that
- -- t1=t3; but alas, the binding for t2 (which mentions t1)
- -- will continue to float out!
- -- Solution: never put methods in avail till they are captured
- -- in which case addFree isn't used
- --
- -- NB3: make sure that CCallable/CReturnable use NoRhs rather
- -- than BoundTo, else we end up with bogus bindings.
- -- c.f. instBindingRequired in addWanted
-addFree (avails, frees) free
- | isDict free = returnNF_Tc (addToFM avails free avail, free:frees)
- | otherwise = returnNF_Tc (avails, free:frees)
- where
- avail | instBindingRequired free = BoundTo (instToId free)
- | otherwise = NoRhs
+addFree avails free = returnNF_Tc (addToFM avails free IsFree)
-addWanted :: RedState -> Inst -> TcExpr -> [Inst] -> NF_TcM RedState
-addWanted state@(avails, frees) wanted rhs_expr wanteds
+addWanted :: Avails -> Inst -> TcExpr -> [Inst] -> NF_TcM Avails
+addWanted avails wanted rhs_expr wanteds
-- Do *not* add superclasses as well. Here's an example of why not
-- class Eq a => Foo a b
-- instance Eq a => Foo [a] a
-- ToDo: this isn't entirely unsatisfactory, because
-- we may also lose some entirely-legitimate sharing this way
- = ASSERT( not (isAvailable state wanted) )
- returnNF_Tc (addToFM avails wanted avail, frees)
+ = ASSERT( not (wanted `elemFM` avails) )
+ returnNF_Tc (addToFM avails wanted avail)
where
avail | instBindingRequired wanted = Rhs rhs_expr wanteds
| otherwise = ASSERT( null wanteds ) NoRhs
-addGiven :: RedState -> Inst -> NF_TcM RedState
-addGiven state given = addAvailAndSCs state given (BoundTo (instToId given))
-
-addIrred :: WantSCs -> RedState -> Inst -> NF_TcM RedState
-addIrred NoSCs (avails,frees) irred = returnNF_Tc (addToFM avails irred Irred, frees)
-addIrred AddSCs state irred = addAvailAndSCs state irred Irred
+addGiven :: Avails -> Inst -> NF_TcM Avails
+addGiven state given = addAvailAndSCs state given (Given (instToId given) False)
-addAvailAndSCs :: RedState -> Inst -> Avail -> NF_TcM RedState
-addAvailAndSCs (avails, frees) wanted avail
- = add_avail_and_scs avails wanted avail `thenNF_Tc` \ avails' ->
- returnNF_Tc (avails', frees)
+addIrred :: WantSCs -> Avails -> Inst -> NF_TcM Avails
+addIrred NoSCs state irred = returnNF_Tc (addToFM state irred Irred)
+addIrred AddSCs state irred = addAvailAndSCs state irred Irred
----------------------
-add_avail_and_scs :: Avails -> Inst -> Avail -> NF_TcM Avails
-add_avail_and_scs avails wanted avail
+addAvailAndSCs :: Avails -> Inst -> Avail -> NF_TcM Avails
+addAvailAndSCs avails wanted avail
= add_scs (addToFM avails wanted avail) wanted
add_scs :: Avails -> Inst -> NF_TcM Avails
add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses
= case lookupFM avails sc_dict of
- Just (BoundTo _) -> returnNF_Tc avails -- See Note [SUPER] below
- other -> add_avail_and_scs avails sc_dict avail
+ Just (Given _ _) -> returnNF_Tc avails -- See Note [SUPER] below
+ other -> addAvailAndSCs avails sc_dict avail
where
sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys) [instToId dict]
avail = Rhs sc_sel_rhs [dict]
Then we'll use the instance decl to deduce C [a] and then add the
superclasses of C [a] to avails. But we must not overwrite the binding
for d1:Ord a (which is given) with a superclass selection or we'll just
-build a loop! Hence looking for BoundTo. Crudely, BoundTo is cheaper
+build a loop! Hence looking for Given. Crudely, Given is cheaper
than a selection.
pprInstsInFull tidy_dicts]
complainCheck doc givens irreds
- = mapNF_Tc zonkInst given_dicts `thenNF_Tc` \ givens' ->
+ = mapNF_Tc zonkInst given_dicts_and_ips `thenNF_Tc` \ givens' ->
mapNF_Tc (addNoInstanceErrs doc givens') (groupInsts irreds) `thenNF_Tc_`
returnNF_Tc ()
where
- given_dicts = filter isDict givens
+ given_dicts_and_ips = filter (not . isMethod) givens
-- Filter out methods, which are only added to
-- the given set as an optimisation
superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind,
isTypeKind,
- IPName, ipNameName, mapIPName,
-
Type, SourceType(..), PredType, ThetaType,
mkForAllTy, mkForAllTys,
mkFunTy, mkFunTys, zipFunTys,
import Type ( -- Re-exports
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
- IPName, Kind, Type, SourceType(..), PredType, ThetaType,
+ Kind, Type, SourceType(..), PredType, ThetaType,
unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
mkForAllTy, mkForAllTys, defaultKind, isTypeKind,
mkFunTy, mkFunTys, zipFunTys,
splitNewType_maybe, splitTyConApp_maybe,
tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, eqKind, eqUsage,
- hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind,
- ipNameName, mapIPName
+ hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind
)
import TyCon ( TyCon, isUnLiftedTyCon )
import Class ( classHasFDs, Class )
import NameSet
import PrelNames -- Lots (e.g. in isFFIArgumentTy)
import TysWiredIn ( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon )
+import BasicTypes ( ipNameName )
import Unique ( Unique, Uniquable(..) )
import SrcLoc ( SrcLoc )
import Util ( cmpList, thenCmp, equalLength )
-- friends:
-- (PprType can see all the representations it's trying to print)
-import TypeRep ( Type(..), TyNote(..), IPName(..),
+import TypeRep ( Type(..), TyNote(..),
Kind, liftedTypeKind ) -- friend
import Type ( SourceType(..), isUTyVar, eqKind )
-import TcType ( ThetaType, PredType, ipNameName,
+import TcType ( ThetaType, PredType,
tcSplitSigmaTy, isPredTy, isDictTy,
tcSplitTyConApp_maybe, tcSplitFunTy_maybe
)
import Outputable
import Unique ( Uniquable(..) )
import Util ( lengthIs )
-import BasicTypes ( tupleParens )
+import BasicTypes ( IPName(..), tupleParens, ipNameName )
import PrelNames -- quite a few *Keys
\end{code}
ppr = pprPred
instance Outputable name => Outputable (IPName name) where
- ppr (Dupable n) = char '?' <> ppr n -- Ordinary implicit parameters
- ppr (MustSplit n) = char '%' <> ppr n -- Splittable implicit parameters
+ ppr (Dupable n) = char '?' <> ppr n -- Ordinary implicit parameters
+ ppr (Linear n) = char '%' <> ppr n -- Splittable implicit parameters
\end{code}
module Type (
-- re-exports from TypeRep:
Type, PredType, ThetaType,
- Kind, TyVarSubst, IPName,
+ Kind, TyVarSubst,
superKind, superBoxity, -- KX and BX respectively
liftedBoxity, unliftedBoxity, -- :: BX
-- Source types
SourceType(..), sourceTypeRep, mkPredTy, mkPredTys,
- ipNameName, mapIPName,
-- Newtypes
splitNewType_maybe,
(tvs, rep_ty) -> substTyWith tvs tys rep_ty
\end{code}
-\begin{code}
-ipNameName :: IPName name -> name
-ipNameName (Dupable n) = n
-ipNameName (MustSplit n) = n
-
-mapIPName :: (a->b) -> IPName a -> IPName b
-mapIPName f (Dupable n) = Dupable (f n)
-mapIPName f (MustSplit n) = MustSplit (f n)
-\end{code}
-
%************************************************************************
%* *
\begin{code}
module TypeRep (
Type(..), TyNote(..), -- Representation visible
- SourceType(..), IPName(..), -- to friends
+ SourceType(..), -- to friends
Kind, PredType, ThetaType, -- Synonyms
TyVarSubst,
#include "HsVersions.h"
-- friends:
-import Var ( TyVar )
-import VarEnv
-import VarSet
-
-import Name ( Name )
-import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon )
-import Class ( Class )
+import Var ( TyVar )
+import VarEnv ( TyVarEnv )
+import VarSet ( TyVarSet )
+import Name ( Name )
+import BasicTypes ( IPName )
+import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon )
+import Class ( Class )
-- others
import PrelNames ( superKindName, superBoxityName, liftedConName,
| NType TyCon [Type] -- A *saturated*, *non-recursive* newtype application
-- [See notes at top about newtypes]
-data IPName name
- = Dupable name -- ?x: you can freely duplicate this implicit parameter
- | MustSplit name -- %x: you must use the splitting function to duplicate it
- deriving( Eq, Ord ) -- Ord is used in the IP name cache finite map
- -- (used in HscTypes.OrigIParamCache)
- -- I sometimes thisnk this type should be in BasicTypes
-
type PredType = SourceType -- A subtype for predicates
type ThetaType = [PredType]
\end{code}
</varlistentry>
<varlistentry>
+ <term>Linear implicit parameters:</term>
+ <listitem>
+ <para><xref LinkEnd="linear-implicit-parameters"></para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
<term>Local universal quantification:</term>
<listitem>
<para><xref LinkEnd="universal-quantification"></para>
</sect1>
+<sect1 id="linear-implicit-parameters">
+<title>Linear implicit parameters
+</title>
+<para>
+Linear implicit parameters are an idea developed by Koen Claessen,
+Mark Shields, and Simon PJ. They address the long-standing
+problem that monads seem over-kill for certain sorts of problem, notably:
+</para>
+<itemizedlist>
+<listitem> <para> distributing a supply of unique names </para> </listitem>
+<listitem> <para> distributing a suppply of random numbers </para> </listitem>
+<listitem> <para> distributing an oracle (as in QuickCheck) </para> </listitem>
+</itemizedlist>
+
+<para>
+Linear implicit parameters are just like ordinary implicit parameters,
+except that they are "linear" -- that is, they cannot be copied, and
+must be explicitly "split" instead. Linear implicit parameters are
+written '<literal>%x</literal>' instead of '<literal>?x</literal>'.
+(The '/' in the '%' suggests the split!)
+</para>
+<para>
+For example:
+<programlisting>
+ data NameSupply = ...
+
+ splitNS :: NameSupply -> (NameSupply, NameSupply)
+ newName :: NameSupply -> Name
+
+ instance PrelSplit.Splittable NameSupply where
+ split = splitNS
+
+
+ f :: (%ns :: NameSupply) => Env -> Expr -> Expr
+ f env (Lam x e) = Lam x' (f env e)
+ where
+ x' = newName %ns
+ env' = extend env x x'
+ ...more equations for f...
+</programlisting>
+Notice that the implicit parameter %ns is consumed
+<itemizedlist>
+<listitem> <para> once by the call to <literal>newName</literal> </para> </listitem>
+<listitem> <para> once by the recursive call to <literal>f</literal> </para></listitem>
+</itemizedlist>
+</para>
+<para>
+So the translation done by the type checker makes
+the parameter explicit:
+<programlisting>
+ f :: NameSupply -> Env -> Expr -> Expr
+ f ns env (Lam x e) = Lam x' (f ns1 env e)
+ where
+ (ns1,ns2) = splitNS ns
+ x' = newName ns2
+ env = extend env x x'
+</programlisting>
+Notice the call to 'split' introduced by the type checker.
+How did it know to use 'splitNS'? Because what it really did
+was to introduce a call to the overloaded function 'split',
+defined by
+<programlisting>
+ class Splittable a where
+ split :: a -> (a,a)
+</programlisting>
+The instance for <literal>Splittable NameSupply</literal> tells GHC how to implement
+split for name supplies. But we can simply write
+<programlisting>
+ g x = (x, %ns, %ns)
+</programlisting>
+and GHC will infer
+<programlisting>
+ g :: (Splittable a, %ns :: a) => b -> (b,a,a)
+</programlisting>
+The <literal>Splittable</literal> class is built into GHC. It's defined in <literal>PrelSplit</literal>,
+and exported by <literal>GlaExts</literal>.
+</para>
+<para>
+Other points:
+<itemizedlist>
+<listitem> <para> '<literal>?x</literal>' and '<literal>%x</literal>'
+are entirely distinct implicit parameters: you
+ can use them together and they won't intefere with each other. </para>
+</listitem>
+
+<listitem> <para> You can bind linear implicit parameters in 'with' clauses. </para> </listitem>
+
+<listitem> <para>You cannot have implicit parameters (whether linear or not)
+ in the context of a class or instance declaration. </para></listitem>
+</itemizedlist>
+</para>
+
+<sect2><title>Warnings</title>
+
+<para>
+The monomorphism restriction is even more important than usual.
+Consider the example above:
+<programlisting>
+ f :: (%ns :: NameSupply) => Env -> Expr -> Expr
+ f env (Lam x e) = Lam x' (f env e)
+ where
+ x' = newName %ns
+ env' = extend env x x'
+</programlisting>
+If we replaced the two occurrences of x' by (newName %ns), which is
+usually a harmless thing to do, we get:
+<programlisting>
+ f :: (%ns :: NameSupply) => Env -> Expr -> Expr
+ f env (Lam x e) = Lam (newName %ns) (f env e)
+ where
+ env' = extend env x (newName %ns)
+</programlisting>
+But now the name supply is consumed in <emphasis>three</emphasis> places
+(the two calls to newName,and the recursive call to f), so
+the result is utterly different. Urk! We don't even have
+the beta rule.
+</para>
+<para>
+Well, this is an experimental change. With implicit
+parameters we have already lost beta reduction anyway, and
+(as John Launchbury puts it) we can't sensibly reason about
+Haskell programs without knowing their typing.
+</para>
+
+</sect2>
+
+</sect1>
<sect1 id="functional-dependencies">
<title>Functional dependencies
--- /dev/null
+\begin{code}
+module PrelSplit( Splittable( split ) ) where
+
+-- The Splittable class for the linear implicit parameters
+-- Can't put it in PrelBase, because of the use of (,)
+
+class Splittable t where
+ split :: t -> (t,t)
+\end{code}
projects / ghc-hetmet.git / commitdiff