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

5 files changed, 46 insertions, 44 deletions

diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 6468bdc576..ac0a7a3e60 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -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] }
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 9f4172b439..c258f82773 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -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
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index cd354890fc..846812df39 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -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}
 
 %************************************************************************
diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs
index dd4baca37b..0a11bfea95 100644
--- a/ghc/compiler/rename/RnHiFiles.lhs
+++ b/ghc/compiler/rename/RnHiFiles.lhs
@@ -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)
 
 -----------------------------------------------------
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index b74e3e77a4..c03839a35d 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -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}