Commit 32a89583 authored by simonpj's avatar simonpj
Browse files

[project @ 2001-11-29 13:47:09 by simonpj]

------------------------------
	Add linear implicit parameters
	------------------------------

Linear implicit parameters are an idea developed by Koen Claessen,
Mark Shields, and Simon PJ, last week.  They address the long-standing
problem that monads seem over-kill for certain sorts of problem, notably:

	* distributing a supply of unique names
	* distributing a suppply of random numbers
	* distributing an oracle (as in QuickCheck)


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 '%x' instead of '?x'.  (The '/' in the '%' suggests the
split!)

For example:

    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...

Notice that the implicit parameter %ns is consumed
	once by the call to newName
	once by the recursive call to f

So the translation done by the type checker makes
the parameter explicit:

    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'

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',
ndefined by

	class Splittable a where
	  split :: a -> (a,a)

The instance for Splittable NameSupply tells GHC how to implement
split for name supplies.  But we can simply write

	g x = (x, %ns, %ns)

and GHC will infer

	g :: (Splittable a, %ns :: a) => b -> (b,a,a)

The Splittable class is built into GHC.  It's defined in PrelSplit,
and exported by GlaExts.

Other points:

* '?x' and '%x' are entirely distinct implicit parameters: you
  can use them together and they won't intefere with each other.

* You can bind linear implicit parameters in 'with' clauses.

* You cannot have implicit parameters (whether linear or not)
  in the context of a class or instance declaration.


Warnings
~~~~~~~~
The monomorphism restriction is even more important than usual.
Consider the example above:

    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'

If we replaced the two occurrences of x' by (newName %ns), which is
usually a harmless thing to do, we get:

    f :: (%ns :: NameSupply) => Env -> Expr -> Expr
    f env (Lam x e) = Lam (newName %ns) (f env e)
		    where
		      env' = extend env x (newName %ns)

But now the name supply is consumed in *three* 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.

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.

Of course, none of this is throughly tested, either.
parent 0fe14834
......@@ -23,6 +23,8 @@ module BasicTypes(
Fixity(..), FixityDirection(..),
defaultFixity, maxPrecedence, negateFixity, negatePrecedence,
IPName(..), ipNameName, mapIPName,
NewOrData(..),
RecFlag(..), isRec, isNonRec,
......@@ -98,6 +100,33 @@ initialVersion = 1
\end{code}
%************************************************************************
%* *
\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}
......
......@@ -45,10 +45,9 @@ import PrelInfo ( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID )
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 )
......
......@@ -21,11 +21,11 @@ import Name ( Name )
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}
......
......@@ -30,7 +30,7 @@ module HsTypes (
#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
......@@ -41,7 +41,7 @@ import OccName ( NameSpace, tvName )
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
)
......
......@@ -64,12 +64,11 @@ import InstEnv ( InstEnv, ClsInstEnv, DFunId )
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.
......@@ -13,7 +13,6 @@ module Parser ( parseModule, parseStmt, parseIdentifier ) where
import HsSyn
import HsTypes ( mkHsTupCon )
import TypeRep ( IPName(..) )
import RdrHsSyn
import Lex
......@@ -29,7 +28,7 @@ import OccName ( UserFS, varName, tcName, dataName, tcClsName, tvName )
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
......@@ -972,8 +971,8 @@ qvar :: { RdrName }
-- *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 }
......
......@@ -95,7 +95,7 @@ knownKeyNames :: [Name]
knownKeyNames
= [
-- Type constructors (synonyms especially)
ioTyConName,
ioTyConName, ioDataConName,
mainName,
orderingTyConName,
rationalTyConName,
......@@ -190,7 +190,8 @@ knownKeyNames
eqStringName,
assertName,
runSTRepName,
printName
printName,
splitIdName, fstIdName, sndIdName -- Used by splittery
]
\end{code}
......@@ -220,6 +221,7 @@ pREL_ARR_Name = mkModuleName "PrelArr"
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"
......@@ -234,6 +236,8 @@ pREL_WORD_Name = mkModuleName "PrelWord"
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
......@@ -358,6 +362,10 @@ listTyConName = tcQual pREL_BASE_Name SLIT("[]") listTyConKey
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
......@@ -506,6 +514,9 @@ errorName = varQual pREL_ERR_Name SLIT("error") errorIdKey
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}
%************************************************************************
......@@ -848,6 +859,9 @@ failIOIdKey = mkPreludeMiscIdUnique 44
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
......
......@@ -39,11 +39,10 @@ import HsCore
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
......@@ -629,8 +628,8 @@ qvar_name : var_name { $1 }
| 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] }
......
......@@ -25,7 +25,6 @@ import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
Deprecations(..), lookupDeprec,
extendLocalRdrEnv
)
import Type ( mapIPName )
import RnMonad
import Name ( Name,
getSrcLoc, nameIsLocalOrFrom,
......@@ -54,6 +53,7 @@ import SrcLoc ( SrcLoc, noSrcLoc )
import Outputable
import ListSetOps ( removeDups, equivClasses )
import Util ( sortLt )
import BasicTypes ( mapIPName )
import List ( nub )
import UniqFM ( lookupWithDefaultUFM )
import CmdLineOpts
......
......@@ -28,13 +28,14 @@ import RnTypes ( rnHsTypeFVs )
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
......@@ -79,8 +80,7 @@ rnPat (SigPatIn pat ty)
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 ->
......@@ -88,15 +88,13 @@ rnPat (LitPatIn lit)
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) ->
......@@ -278,7 +276,12 @@ rnExpr (HsVar v)
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 ->
......@@ -341,12 +344,12 @@ rnExpr section@(SectionR op expr)
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) ->
......@@ -370,7 +373,6 @@ rnExpr (HsWith expr binds)
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 {
......@@ -379,7 +381,7 @@ rnExpr e@(HsDo do_or_lc stmts src_loc)
} `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.
......@@ -424,9 +426,8 @@ rnExpr (HsType a)
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) ->
......@@ -811,8 +812,7 @@ litFVs (HsInt i) = returnRn (unitFV (getName intTyCon))
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
......@@ -820,18 +820,20 @@ rnOverLit (HsIntegral i from_integer_name)
= 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.
......@@ -839,7 +841,8 @@ rnOverLit (HsFractional i from_rat_name)
-- 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}
%************************************************************************
......
......@@ -322,6 +322,7 @@ loadDecl mod (version_map, decls_map) (version, decl)
new_version_map = extendNameEnv version_map main_name version
in
traceRn (text "Loading" <+> ppr full_avail) `thenRn_`
returnRn (new_version_map, new_decls_map)
-----------------------------------------------------
......
......@@ -37,8 +37,8 @@ import DataCon ( dataConId )
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 )
......@@ -131,19 +131,18 @@ rnSourceDecl (DefD (DefaultDecl tys src_loc))
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}
......
......@@ -11,9 +11,9 @@ module Inst (
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,
......@@ -21,7 +21,7 @@ module Inst (
lookupInst, lookupSimpleInst, LookupInstResult(..),
isDict, isClassDict, isMethod,
isDict, isClassDict, isMethod, isLinearInst, linearInstType,
isTyVarDict, isStdClassTyVarDict, isMethodFor,
instBindingRequired, instCanBeGeneralised,
......@@ -54,12 +54,11 @@ import TcType ( Type, TcType, TcThetaType, TcPredType, TcTauType, TcTyVarSet,
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 )
......@@ -72,6 +71,8 @@ import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames( fromIntegerName, fromRationalName )
import Util ( thenCmp, equalLength )
import BasicTypes( IPName(..), mapIPName, ipNameName )
import Bag
import Outputable
\end{code}
......@@ -262,6 +263,22 @@ 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 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
......@@ -297,6 +314,10 @@ newDicts orig theta
= 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
......@@ -360,35 +381,36 @@ This gets a bit less sharing, but
\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
......
......@@ -47,8 +47,7 @@ import DataCon ( dataConWrapId )
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,
......@@ -58,7 +57,7 @@ import TysWiredIn ( charTy, stringTy, intTy, integerTy,
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(..) )
......@@ -632,8 +631,8 @@ zonkRbinds rbinds
-------------------------------------------------------------------------
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}
......
......@@ -44,7 +44,7 @@ import {-# SOURCE #-} TcEnv ( TcEnv )
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,
......@@ -57,6 +57,7 @@ import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
splitUniqSupply, mkSplitUniqSupply,
UniqSM, initUs_ )
import SrcLoc ( SrcLoc, noSrcLoc )
import BasicTypes ( IPName )
import UniqFM ( emptyUFM )
import Unique ( Unique )
import CmdLineOpts
......
......@@ -27,33 +27,35 @@ import TcHsSyn ( TcExpr, TcId,
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,