[project @ 1997-11-11 14:28:12 by simonm]

Compiler changes to:

	* remove PrimIO
	* change type of _ccall_ to IO.

(includes commits to basicTypes/Unique.lhs, deSugar/DsCCall.lhs, and
 prelude/PrelInfo.lhs, but the commit script messed up).

ghc/compiler/prelude/PrelMods.lhs

@@ -17,9 +17,10 @@ module PrelMods
          gHC__, pRELUDE, pREL_BASE,
          pREL_READ , pREL_NUM, pREL_LIST,
 	 pREL_TUP  , pACKED_STRING, cONC_BASE,
-         iO_BASE   , mONAD, rATIO, iX,
+         iO_BASE   , eRROR, mONAD, rATIO, iX,
          sT_BASE   , aRR_BASE, fOREIGN, mAIN,
-         gHC_MAIN  , gHC_ERR
+         gHC_MAIN  , gHC_ERR,
+	 cCALL     , aDDR
 	) where
 
 CHK_Ubiq() -- debugging consistency check
@@ -43,12 +44,15 @@ pREL_TUP     = SLIT("PrelTup")
 pACKED_STRING= SLIT("PackBase")
 cONC_BASE    = SLIT("ConcBase")
 iO_BASE	     = SLIT("IOBase")
+eRROR	     = SLIT("Error")
 mONAD	     = SLIT("Monad")
 rATIO	     = SLIT("Ratio")
 iX	     = SLIT("Ix")
 sT_BASE	     = SLIT("STBase")
 aRR_BASE     = SLIT("ArrBase")
 fOREIGN	     = SLIT("Foreign")
+cCALL        = SLIT("CCall")
+aDDR         = SLIT("Addr")
 
 mAIN	     = SLIT("Main")
 gHC_MAIN     = SLIT("GHCmain")

ghc/compiler/prelude/PrelVals.lhs

@@ -93,7 +93,7 @@ pc_bottoming_Id key mod name ty
 	-- these "bottom" out, no matter what their arguments
 
 eRROR_ID
-  = pc_bottoming_Id errorIdKey iO_BASE SLIT("error") errorTy
+  = pc_bottoming_Id errorIdKey eRROR SLIT("error") errorTy
 
 generic_ERROR_ID u n
   = pc_bottoming_Id u gHC_ERR n errorTy

ghc/compiler/prelude/PrimOp.lhs

@@ -1380,13 +1380,11 @@ primOpInfo NoFollowOp	-- noFollow# :: a -> a
 %************************************************************************
 
 \begin{code}
-primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld#
-  = PrimResult SLIT("errorIO#") []
-	[primio_ish_ty unitTy]
+-- errorIO# :: (State# RealWorld# -> a) -> State# RealWorld#
+primOpInfo ErrorIOPrimOp
+  = PrimResult SLIT("errorIO#") [alphaTyVar]
+	[mkFunTy realWorldStatePrimTy alphaTy]
 	statePrimTyCon VoidRep [realWorldTy]
-  where
-    primio_ish_ty result
-      = mkFunTy (mkStatePrimTy realWorldTy) (mkSTretTy realWorldTy result)
 \end{code}
 
 %************************************************************************

ghc/compiler/prelude/TysWiredIn.lhs

@@ -46,21 +46,26 @@ module TysWiredIn (
 	liftTyCon,
 	listTyCon,
 	foreignObjTyCon,
+
 	mkLiftTy,
 	mkListTy,
-	mkPrimIoTy,
-	mkStateTy,
-	mkStateTransformerTy,
-	tupleTyCon, tupleCon, unitTyCon, unitDataCon, pairTyCon, pairDataCon,
 	mkTupleTy,
+	tupleTyCon, tupleCon, unitTyCon, unitDataCon, pairTyCon, pairDataCon,
 	nilDataCon,
-	primIoTyCon,
 	realWorldStateTy,
 	return2GMPsTyCon,
 	returnIntAndGMPTyCon,
+
+	-- ST and STret types
+	mkStateTy,
+	mkStateTransformerTy,
+	mkSTretTy,
 	stTyCon,
 	stDataCon,
-	stablePtrTyCon,
+	stRetDataCon,
+	stRetTyCon,
+
+	-- CCall result types
 	stateAndAddrPrimTyCon,
 	stateAndArrayPrimTyCon,
 	stateAndByteArrayPrimTyCon,
@@ -77,9 +82,8 @@ module TysWiredIn (
 	stateAndWordPrimTyCon,
 	stateDataCon,
 	stateTyCon,
-	stRetDataCon,
-	stRetTyCon,
-	mkSTretTy,
+
+	stablePtrTyCon,
 	stringTy,
 	trueDataCon,
 	unitTy,
@@ -258,8 +262,8 @@ wordDataCon = pcDataCon wordDataConKey fOREIGN SLIT("W#") [] [] [wordPrimTy] wor
 \begin{code}
 addrTy = mkTyConTy addrTyCon
 
-addrTyCon = pcDataTyCon addrTyConKey   fOREIGN SLIT("Addr") [] [addrDataCon]
-addrDataCon = pcDataCon addrDataConKey fOREIGN SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv
+addrTyCon = pcDataTyCon addrTyConKey   aDDR SLIT("Addr") [] [addrDataCon]
+addrDataCon = pcDataCon addrDataConKey aDDR SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv
 \end{code}
 
 \begin{code}
@@ -286,18 +290,6 @@ stateDataCon
 	alpha_tyvar [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv
 \end{code}
 
-\begin{code}
-mkSTretTy alpha beta = applyTyCon stRetTyCon [alpha,beta]
-
-stRetTyCon
-  = pcDataTyCon stRetTyConKey sT_BASE SLIT("STret") 
-	alpha_beta_tyvars [stRetDataCon]
-stRetDataCon
-  = pcDataCon stRetDataConKey sT_BASE SLIT("STret")
-	alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy] 
-		stRetTyCon nullSpecEnv
-\end{code}
-
 \begin{code}
 stablePtrTyCon
   = pcDataTyCon stablePtrTyConKey fOREIGN SLIT("StablePtr")
@@ -534,7 +526,8 @@ getStatePairingConInfo prim_ty
 %*									*
 %************************************************************************
 
-This is really just an ordinary synonym, except it is ABSTRACT.
+The only reason this is wired in is because we have to represent the
+type of runST.
 
 \begin{code}
 mkStateTransformerTy s a = applyTyCon stTyCon [s, a]
@@ -545,22 +538,16 @@ stDataCon = pcDataCon stDataConKey sT_BASE SLIT("ST")
 			alpha_beta_tyvars [] [ty] stTyCon nullSpecEnv
   where
     ty = mkFunTy (mkStatePrimTy alphaTy) (mkSTretTy alphaTy betaTy)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[TysWiredIn-IO]{The @PrimIO@ monadic-I/O type}
-%*									*
-%************************************************************************
 
-\begin{code}
-mkPrimIoTy a = mkStateTransformerTy realWorldTy a
+mkSTretTy alpha beta = applyTyCon stRetTyCon [alpha,beta]
 
-primIoTyCon
-  = pcSynTyCon
-     primIoTyConKey sT_BASE SLIT("PrimIO")
-     (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind)
-     1 alpha_tyvar (mkPrimIoTy alphaTy)
+stRetTyCon
+  = pcDataTyCon stRetTyConKey sT_BASE SLIT("STret") 
+	alpha_beta_tyvars [stRetDataCon]
+stRetDataCon
+  = pcDataCon stRetDataConKey sT_BASE SLIT("STret")
+	alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy] 
+		stRetTyCon nullSpecEnv
 \end{code}
 
 %************************************************************************

ghc/compiler/rename/Rename.lhs

@@ -42,7 +42,6 @@ import Name		( Name, Provenance, ExportFlag(..), isLocallyDefined,
 			  nameModule, pprModule, pprOccName, nameOccName
 			)
 import TysWiredIn	( unitTyCon, intTyCon, doubleTyCon )
-import PrelInfo		( ioTyCon_NAME, primIoTyCon_NAME )
 import TyCon		( TyCon )
 import PrelMods		( mAIN, gHC_MAIN )
 import ErrUtils		( SYN_IE(Error), SYN_IE(Warning), pprBagOfErrors, 
@@ -172,18 +171,13 @@ mentioned explicitly, but which might be needed by the type checker.
 
 \begin{code}
 addImplicits mod_name
-  = addImplicitOccsRn (implicit_main ++ default_tys)
+  = addImplicitOccsRn default_tys
   where
 	-- Add occurrences for Int, Double, and (), because they
 	-- are the types to which ambigious type variables may be defaulted by
 	-- the type checker; so they won't every appear explicitly.
 	-- [The () one is a GHC extension for defaulting CCall results.]
-    default_tys = [getName intTyCon, getName doubleTyCon, getName unitTyCon]
-
-	-- Add occurrences for IO or PrimIO
-    implicit_main | mod_name == mAIN     = [ioTyCon_NAME]
-		  | mod_name == gHC_MAIN = [primIoTyCon_NAME]
-		  | otherwise 		 = []
+    default_tys = [getName intTyCon, getName doubleTyCon, getName unitTyCon ]
 \end{code}
 
 

ghc/compiler/rename/RnExpr.lhs

@@ -32,9 +32,11 @@ import RnMonad
 import RnEnv
 import CmdLineOpts	( opt_GlasgowExts )
 import BasicTypes	( Fixity(..), FixityDirection(..) )
-import PrelInfo		( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR,
-			  creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
-			  ratioDataCon_RDR, negate_RDR
+import PrelInfo		( numClass_RDR, fractionalClass_RDR, eqClass_RDR, 
+			  ccallableClass_RDR, creturnableClass_RDR, 
+			  monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
+			  ratioDataCon_RDR, negate_RDR, 
+			  ioDataCon_RDR, ioOkDataCon_RDR
 			)
 import TysPrim		( charPrimTyCon, addrPrimTyCon, intPrimTyCon, 
 			  floatPrimTyCon, doublePrimTyCon
@@ -315,6 +317,8 @@ rnExpr (SectionR op expr)
 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
   = lookupImplicitOccRn ccallableClass_RDR	`thenRn_`
     lookupImplicitOccRn creturnableClass_RDR	`thenRn_`
+    lookupImplicitOccRn ioDataCon_RDR		`thenRn_`
+    lookupImplicitOccRn ioOkDataCon_RDR		`thenRn_`
     rnExprs args				`thenRn` \ (args', fvs_args) ->
     returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
 

ghc/compiler/typecheck/TcExpr.lhs

@@ -31,7 +31,8 @@ import Inst		( Inst, InstOrigin(..), OverloadedLit(..),
 import TcBinds		( tcBindsAndThen, checkSigTyVars )
 import TcEnv		( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
 			  tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
-			  tcExtendGlobalTyVars, tcLookupGlobalValueMaybe 
+			  tcExtendGlobalTyVars, tcLookupGlobalValueMaybe,
+			  tcLookupTyCon
 			)
 import SpecEnv		( SpecEnv )
 import TcMatches	( tcMatchesCase, tcMatchExpected )
@@ -59,13 +60,14 @@ import Type		( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy,
 			  getAppDataTyCon, maybeAppDataTyCon
 			)
 import TyVar		( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, elementOfTyVarSet, mkTyVarSet )
+import TyCon		( tyConDataCons )
 import TysPrim		( intPrimTy, charPrimTy, doublePrimTy,
 			  floatPrimTy, addrPrimTy, realWorldTy
 			)
-import TysWiredIn	( addrTy,
-			  boolTy, charTy, stringTy, mkListTy,
-			  mkTupleTy, mkPrimIoTy, stDataCon
+import TysWiredIn	( addrTy, mkTupleTy,
+			  boolTy, charTy, stringTy, mkListTy
 			)
+import PrelInfo		( ioTyCon_NAME )
 import Unify		( unifyTauTy, unifyTauTyList, unifyTauTyLists, 
 			  unifyFunTy, unifyListTy, unifyTupleTy
 			)
@@ -251,6 +253,7 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
   = 	-- Get the callable and returnable classes.
     tcLookupClassByKey cCallableClassKey	`thenNF_Tc` \ cCallableClass ->
     tcLookupClassByKey cReturnableClassKey	`thenNF_Tc` \ cReturnableClass ->
+    tcLookupTyCon ioTyCon_NAME			`thenTc` \ (_,_,ioTyCon) ->
 
     let
 	new_arg_dict (arg, arg_ty)
@@ -266,20 +269,27 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
     tcExprs args ty_vars		   		       `thenTc`    \ (args', args_lie) ->
 
 	-- The argument types can be unboxed or boxed; the result
-	-- type must, however, be boxed since it's an argument to the PrimIO
+	-- type must, however, be boxed since it's an argument to the IO
 	-- type constructor.
     newTyVarTy mkBoxedTypeKind  		`thenNF_Tc` \ result_ty ->
-    unifyTauTy (mkPrimIoTy result_ty) res_ty    `thenTc_`
+    let
+	io_result_ty = applyTyCon ioTyCon [result_ty]
+    in
+    case tyConDataCons ioTyCon of { [ioDataCon] ->
+    unifyTauTy io_result_ty res_ty   `thenTc_`
 
 	-- Construct the extra insts, which encode the
 	-- constraints on the argument and result types.
-    mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args ty_vars)    `thenNF_Tc` \ ccarg_dicts_s ->
-    newDicts result_origin [(cReturnableClass, result_ty)]	    `thenNF_Tc` \ (ccres_dict, _) ->
+    mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args ty_vars)    
+						`thenNF_Tc` \ ccarg_dicts_s ->
+    newDicts result_origin [(cReturnableClass, result_ty)]	    
+						`thenNF_Tc` \ (ccres_dict, _) ->
 
-    returnTc (HsApp (HsVar (RealId stDataCon) `TyApp` [realWorldTy, result_ty])
-		    (CCall lbl args' may_gc is_asm result_ty),
+    returnTc (HsApp (HsVar (RealId ioDataCon) `TyApp` [result_ty])
+		    (CCall lbl args' may_gc is_asm io_result_ty),
 		      -- do the wrapping in the newtype constructor here
 	      foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
+    }
 \end{code}
 
 \begin{code}

ghc/compiler/typecheck/TcModule.lhs

@@ -63,7 +63,7 @@ import Type		( applyTyCon, mkSynTy, SYN_IE(Type) )
 import PprType		( GenType, GenTyVar )
 import TysWiredIn	( unitTy )
 import PrelMods		( gHC_MAIN, mAIN )
-import PrelInfo		( main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME )
+import PrelInfo		( main_NAME, ioTyCon_NAME )
 import TyVar		( GenTyVar, SYN_IE(TyVarEnv), nullTyVarEnv )
 import Unify		( unifyTauTy )
 import UniqFM		( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
@@ -284,50 +284,38 @@ get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
 
 \begin{code}
 tcCheckMainSig mod_name
-  | not is_main && not is_ghc_main
+  | mod_name /= mAIN
   = returnTc ()		-- A non-main module
 
   | otherwise
   = 	-- Check that main is defined
-    tcLookupTyCon tycon_name			`thenTc` \ (_,_,tycon) ->
-    tcLookupLocalValue main_name		`thenNF_Tc` \ maybe_main_id ->
+    tcLookupTyCon ioTyCon_NAME		`thenTc`    \ (_,_,ioTyCon) ->
+    tcLookupLocalValue main_NAME	`thenNF_Tc` \ maybe_main_id ->
     case maybe_main_id of {
-	Nothing	 -> failTc (noMainErr mod_name main_name);
+	Nothing	 -> failTc noMainErr;
 	Just main_id   ->
 
 	-- Check that it has the right type (or a more general one)
-    let
-	expected_ty | isSynTyCon tycon = mkSynTy tycon [unitTy]
-		    | otherwise	       = applyTyCon tycon [unitTy]
-		-- This is bizarre.  There ought to be a suitable function in Type.lhs!
-    in
-    tcInstType [] expected_ty			`thenNF_Tc` \ expected_tau ->
-    tcId main_name				`thenNF_Tc` \ (_, lie, main_tau) ->
-    tcSetErrCtxt (mainTyCheckCtxt main_name) $
+    let expected_ty = applyTyCon ioTyCon [unitTy] in
+    tcInstType [] expected_ty		`thenNF_Tc` \ expected_tau ->
+    tcId main_NAME			`thenNF_Tc` \ (_, lie, main_tau) ->
+    tcSetErrCtxt mainTyCheckCtxt $
     unifyTauTy expected_tau
-	       main_tau				`thenTc_`
-    checkTc (isEmptyBag lie) (mainTyMisMatch main_name expected_ty (idType main_id))
+	       main_tau			`thenTc_`
+    checkTc (isEmptyBag lie) (mainTyMisMatch expected_ty (idType main_id))
     }
-  where
-    is_main     = mod_name == mAIN
-    is_ghc_main = mod_name == gHC_MAIN
-
-    main_name | is_main   = main_NAME
-	      | otherwise = mainPrimIO_NAME
-
-    tycon_name | is_main   = ioTyCon_NAME
-	       | otherwise = primIoTyCon_NAME
 
-mainTyCheckCtxt main_name sty
-  = hsep [ptext SLIT("When checking that"), ppr sty main_name, ptext SLIT("has the required type")]
+mainTyCheckCtxt sty
+  = hsep [ptext SLIT("When checking that"), ppr sty main_NAME, 
+	  ptext SLIT("has the required type")]
 
-noMainErr mod_name main_name sty
-  = hsep [ptext SLIT("Module"), pprModule sty mod_name, 
-	   ptext SLIT("must include a definition for"), ppr sty main_name]
+noMainErr sty
+  = hsep [ptext SLIT("Module"), pprModule sty mAIN, 
+	   ptext SLIT("must include a definition for"), ppr sty main_NAME]
 
-mainTyMisMatch :: Name -> Type -> TcType s -> Error
-mainTyMisMatch main_name expected actual sty
-  = hang (hsep [ppr sty main_name, ptext SLIT("has the wrong type")])
+mainTyMisMatch :: Type -> TcType s -> Error
+mainTyMisMatch expected actual sty
+  = hang (hsep [ppr sty main_NAME, ptext SLIT("has the wrong type")])
 	 4 (vcat [
 			hsep [ptext SLIT("Expected:"), ppr sty expected],
 			hsep [ptext SLIT("Inferred:"), ppr sty actual]