diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index 9aa57b9f5ea8d8919fba759757c7b2dd9af695b2..17c9d572d40733fa0cd2211b427971763eb9696c 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -192,8 +192,10 @@ module Unique (
 	stateAndWordPrimDataConKey,
 	stateAndWordPrimTyConKey,
 	stateDataConKey,
+	stRetDataConKey,
 	statePrimTyConKey,
 	stateTyConKey,
+	stRetTyConKey,
 	synchVarPrimTyConKey,
 	thenMClassOpKey,
 	toEnumClassOpKey,
@@ -573,6 +575,7 @@ byteArrayTyConKey			= mkPreludeTyConUnique 52
 wordPrimTyConKey			= mkPreludeTyConUnique 53
 wordTyConKey				= mkPreludeTyConUnique 54
 voidTyConKey				= mkPreludeTyConUnique 55
+stRetTyConKey				= mkPreludeTyConUnique 56
 \end{code}
 
 %************************************************************************
@@ -619,6 +622,7 @@ stateDataConKey				= mkPreludeDataConUnique 39
 trueDataConKey				= mkPreludeDataConUnique 40
 wordDataConKey				= mkPreludeDataConUnique 41
 stDataConKey				= mkPreludeDataConUnique 42
+stRetDataConKey				= mkPreludeDataConUnique 43
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index 15758da0c529f0cdb06c4a12f92b2326e1cc91ce..4d3e3ed77cb036fe111b58f778b8f0648be0b354 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -29,8 +29,9 @@ import Type		( isPrimType, maybeAppDataTyConExpandingDicts, maybeAppTyCon,
 import TysPrim		( byteArrayPrimTy, realWorldTy,  realWorldStatePrimTy,
 			  byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
 import TysWiredIn	( getStatePairingConInfo,
-			  realWorldStateTy, stateDataCon, pairDataCon, unitDataCon,
-			  stringTy
+			  stRetDataCon, pairDataCon, unitDataCon,
+			  stringTy,
+			  realWorldStateTy, stateDataCon
 			)
 import Util		( pprPanic, pprError, panic )
 
@@ -80,11 +81,14 @@ dsCCall :: FAST_STRING	-- C routine to invoke
 	-> DsM CoreExpr
 
 dsCCall label args may_gc is_asm result_ty
-  = newSysLocalDs realWorldStateTy	`thenDs` \ old_s ->
+  = newSysLocalDs realWorldStatePrimTy	`thenDs` \ old_s ->
 
-    mapAndUnzipDs unboxArg (Var old_s : args)	`thenDs` \ (final_args, arg_wrappers) ->
+    mapAndUnzipDs unboxArg args	`thenDs` \ (unboxed_args, arg_wrappers) ->
+    let
+	 final_args = Var old_s : unboxed_args
+    in
 
-    boxResult result_ty				`thenDs` \ (final_result_ty, res_wrapper) ->
+    boxResult result_ty		`thenDs` \ (final_result_ty, res_wrapper) ->
 
     let
 	the_ccall_op = CCallOp label is_asm may_gc
@@ -188,20 +192,20 @@ boxResult result_ty
   -- oops! can't see the data constructors
   = can't_see_datacons_error "result" result_ty
 
-  -- Data types with a single constructor, which has a single, primitive-typed arg
-  | (maybeToBool maybe_data_type) &&				-- Data type
-    (null other_data_cons) &&					-- Just one constr
-    not (null data_con_arg_tys) && null other_args_tys	&& 	-- Just one arg
-    isPrimType the_prim_result_ty				-- of primitive type
+  -- Data types with a single constructor, 
+  -- which has a single, primitive-typed arg.
+  | (maybeToBool maybe_data_type) &&			   -- Data type
+    (null other_data_cons) &&				   -- Just one constr
+    not (null data_con_arg_tys) && null other_args_tys	&& -- Just one arg
+    isPrimType the_prim_result_ty			   -- of primitive type
   =
-    newSysLocalDs realWorldStatePrimTy			`thenDs` \ prim_state_id ->
-    newSysLocalDs the_prim_result_ty 			`thenDs` \ prim_result_id ->
+    newSysLocalDs realWorldStatePrimTy		`thenDs` \ prim_state_id ->
+    newSysLocalDs the_prim_result_ty 		`thenDs` \ prim_result_id ->
 
-    mkConDs stateDataCon [TyArg realWorldTy, VarArg (Var prim_state_id)]  `thenDs` \ new_state ->
     mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
 
-    mkConDs pairDataCon
-	    [TyArg result_ty, TyArg realWorldStateTy, VarArg the_result, VarArg new_state]
+    mkConDs stRetDataCon
+	    [TyArg realWorldTy, TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
 							`thenDs` \ the_pair ->
     let
 	the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
@@ -217,10 +221,8 @@ boxResult result_ty
   =
     newSysLocalDs realWorldStatePrimTy		`thenDs` \ prim_state_id ->
 
-    mkConDs stateDataCon [TyArg realWorldTy, VarArg (Var prim_state_id)]
-						`thenDs` \ new_state ->
-    mkConDs pairDataCon
-	    [TyArg result_ty, TyArg realWorldStateTy, VarArg (Var unitDataCon), VarArg new_state]
+    mkConDs stRetDataCon
+	    [TyArg realWorldTy, TyArg result_ty, VarArg (Var prim_state_id), VarArg (Var unitDataCon)]
 						`thenDs` \ the_pair ->
 
     let
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index 5b841972069d06e8dbb8a2b4a09fa97a1afcfc59..7abfbabbcea31c31b2391fbb965aa3acacba1f0f 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -169,7 +169,7 @@ data_tycons
     , stateAndStablePtrPrimTyCon
     , stateAndSynchVarPrimTyCon
     , stateAndWordPrimTyCon
-    , stateTyCon
+    , stRetTyCon
     , voidTyCon
     , wordTyCon
     ]
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index d02fe6d48eeadc3bfc7d5b95556dbb0c027a67f1..ab2428c4e3d2692bcfd1865b7063864e365db05b 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -1383,7 +1383,7 @@ primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld#
 	statePrimTyCon VoidRep [realWorldTy]
   where
     primio_ish_ty result
-      = mkFunTy (mkStateTy realWorldTy) (mkTupleTy 2 [result, mkStateTy realWorldTy])
+      = mkFunTy (mkStatePrimTy realWorldTy) (mkSTretTy realWorldTy result)
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index c66d2157d1283af60f5d8f861314b588993cf17c..e689b5333d1696f0d36d84ae1c52b178a946c768 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -77,6 +77,9 @@ module TysWiredIn (
 	stateAndWordPrimTyCon,
 	stateDataCon,
 	stateTyCon,
+	stRetDataCon,
+	stRetTyCon,
+	mkSTretTy,
 	stringTy,
 	trueDataCon,
 	unitTy,
@@ -283,6 +286,18 @@ 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")
@@ -529,7 +544,7 @@ stTyCon = pcNewTyCon stTyConKey sT_BASE SLIT("ST") alpha_beta_tyvars [stDataCon]
 stDataCon = pcDataCon stDataConKey sT_BASE SLIT("ST")
 			alpha_beta_tyvars [] [ty] stTyCon nullSpecEnv
   where
-    ty = mkFunTy (mkStateTy alphaTy) (mkTupleTy 2 [betaTy, mkStateTy alphaTy])
+    ty = mkFunTy (mkStatePrimTy alphaTy) (mkSTretTy alphaTy betaTy)
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 4a9e8a8696fae9fc30df65913286e5fe9e3ab39e..7997378d898ee653737df2812582f917b0063194 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -42,7 +42,6 @@ import Type		( tyVarsOfType, mkForAllTys, mkTyVarTys, isPrimType, getTyVar_maybe
 			  maybeAppDataTyConExpandingDicts, SYN_IE(Type)
 			)
 import TyCon		( isDataTyCon )
-import TysWiredIn	( realWorldStateTy )
 import TyVar		( elementOfTyVarSet,
 			  GenTyVar{-instance Eq-} )
 import Util		( isIn, panic, assertPanic )
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 91e1c779cf749304856962c93d6da1acec97e495..b08bd2a7f1a02d09d553246eccff814ebcb42c3b 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -53,7 +53,7 @@ import SimplUtils
 import Type		( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, maybeAppDataTyCon,
 			  splitFunTy, splitFunTyExpandingDicts, getFunTy_maybe, eqTy
 			)
-import TysWiredIn	( realWorldStateTy )
+import TysPrim		( realWorldStatePrimTy )
 import Outputable	( PprStyle(..), Outputable(..) )
 import Util		( SYN_IE(Eager), appEager, returnEager, runEager, mapEager,
 			  isSingleton, zipEqual, zipWithEqual, mapAndUnzip, panic, pprPanic, assertPanic, pprTrace )
@@ -720,8 +720,8 @@ simplValLam env expr min_no_of_args expr_ty
 				-- but usually doesn't
 			   `max`
 			   case potential_extra_binder_tys of
-				[ty] | ty `eqTy` realWorldStateTy -> 1
-				other				  -> 0
+				[ty] | ty `eqTy` realWorldStatePrimTy -> 1
+				other				      -> 0
 \end{code}
 
 
diff --git a/ghc/driver/ghc-asm.lprl b/ghc/driver/ghc-asm.lprl
index 06a641615d9fe762908900816f0f8d7529e8831a..8c99b70af3a45690541c2190b6404292ff128083 100644
--- a/ghc/driver/ghc-asm.lprl
+++ b/ghc/driver/ghc-asm.lprl
@@ -1382,7 +1382,6 @@ sub init_FUNNY_THINGS {
 	"${T_US}UnderflowVect7${T_POST_LBL}", 1,
 	"${T_US}UpdErr${T_POST_LBL}", 1,
 	"${T_US}UpdatePAP${T_POST_LBL}", 1,
-	"${T_US}WorldStateToken${T_POST_LBL}", 1,
 	"${T_US}_Enter_Internal${T_POST_LBL}", 1,
 	"${T_US}_PRMarking_MarkNextAStack${T_POST_LBL}", 1,
 	"${T_US}_PRMarking_MarkNextBStack${T_POST_LBL}", 1,
diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl
index ea27869fa000537e39827ac50a2973d124f9306c..78070dcdde0354c3a9bcba503d64516541226d2e 100644
--- a/ghc/driver/ghc.lprl
+++ b/ghc/driver/ghc.lprl
@@ -1195,7 +1195,6 @@ sub setupLinkOpts {
           ,'-u', "${uscore}PrelBase_CZh_static_info"
           ,'-u', "${uscore}PrelBase_False_inregs_info"
           ,'-u', "${uscore}PrelBase_True_inregs_info"
-	  ,'-u', "${uscore}STBase_SZh_static_info"
           ,'-u', "${uscore}DEBUG_REGS"
 	));
   if ($TargetPlatform =~ /^powerpc-|^rs6000-/) {
diff --git a/ghc/lib/concurrent/Channel.lhs b/ghc/lib/concurrent/Channel.lhs
index 417e139718e4229bfcc4cce2fa8a05388b88cdc2..7bf6d180e2d904f405af559347d0e084e13b1b8c 100644
--- a/ghc/lib/concurrent/Channel.lhs
+++ b/ghc/lib/concurrent/Channel.lhs
@@ -27,7 +27,7 @@ module Channel
        ) where
 
 import Prelude
-import IOBase	( IO(..) )		-- Suspicious!
+import IOBase	( IO(..), ioToST, stToIO )		-- Suspicious!
 import ConcBase
 import STBase
 import UnsafeST ( unsafeInterleavePrimIO )
@@ -114,30 +114,13 @@ Operators for interfacing with functional streams.
 
 getChanContents :: Chan a -> IO [a]
 getChanContents ch
-{- WAS:
-  = unsafeInterleavePrimIO (
-      getChan ch 				   `thenPrimIO` \ ~(Right x) ->
-      unsafeInterleavePrimIO (getChanContents ch)  `thenPrimIO` \ ~(Right xs) ->
-      returnPrimIO  (Right (x:xs)))
--}
-  = my_2_IO $ unsafeInterleavePrimIO (
-	getChan_prim ch 			         >>= \ ~(Right x) ->
-	unsafeInterleavePrimIO (getChanContents_prim ch) >>= \ ~(Right xs) ->
-	returnPrimIO  (Right (x:xs)))
-
-my_2_IO :: PrimIO (Either IOError a) -> IO a -- simple; primIOToIO does too much!
-my_2_IO m = IO m
-
-getChan_prim	     :: Chan a -> PrimIO (Either IOError  a)
-getChanContents_prim :: Chan a -> PrimIO (Either IOError [a])
-
-getChan_prim ch = ST $ \ s ->
-    case (getChan ch) of { IO (ST get) ->
-    get s }
-
-getChanContents_prim ch = ST $ \ s ->
-    case (getChanContents ch) of { IO (ST get) ->
-    get s }
+  = unsafeInterleaveIO (do
+	x <- getChan ch
+    	xs <- getChanContents ch
+    	return (x:xs)
+    )
+
+unsafeInterleaveIO = stToIO . unsafeInterleavePrimIO . ioToST
 
 -------------
 putList2Chan :: Chan a -> [a] -> IO ()
diff --git a/ghc/lib/ghc/ArrBase.lhs b/ghc/lib/ghc/ArrBase.lhs
index cee229dc7581b0596fac87dfc63990ae8d5bf3e4..c736fed70a59851c25ecf60418174ba4a4a87c93 100644
--- a/ghc/lib/ghc/ArrBase.lhs
+++ b/ghc/lib/ghc/ArrBase.lhs
@@ -90,16 +90,18 @@ bounds (Array b _)  = b
 array ixs@(ix_start, ix_end) ivs =
    runST ( ST $ \ s ->
 	case (newArray ixs arrEleBottom)	of { ST new_array_thing ->
-	case (new_array_thing s)		of { (arr@(MutableArray _ arr#),s) ->
+	case (new_array_thing s)		of { STret s# arr@(MutableArray _ arr#) ->
 	let
-         fill_one_in (S# s#) (i, v)
-             = case index ixs  i		of { I# n# ->
-	       case writeArray# arr# n# v s# 	of { s2#   ->
-	       S# s2# }}
+	 fill_in s# [] = s#
+	 fill_in s# ((i,v):ivs) =
+		case (index ixs i)	      of { I# n# ->
+		case writeArray# arr# n# v s# of { s2# -> 
+		fill_in s2# ivs }}
 	in
-	case (foldl fill_one_in s ivs) 		of { s@(S# _) -> 
+
+	case (fill_in s# ivs)	 		of { s# -> 
 	case (freezeArray arr)			of { ST freeze_array_thing ->
-	freeze_array_thing s }}}})
+	freeze_array_thing s# }}}})
 
 arrEleBottom = error "(Array.!): undefined array element"
 
@@ -189,35 +191,35 @@ newCharArray, newIntArray, newAddrArray, newFloatArray, newDoubleArray
 {-# SPECIALIZE newFloatArray  :: IPr -> ST s (MutableByteArray s Int) #-}
 {-# SPECIALIZE newDoubleArray :: IPr -> ST s (MutableByteArray s Int) #-}
 
-newArray ixs init = ST $ \ (S# s#) ->
+newArray ixs init = ST $ \ s# ->
     case rangeSize ixs              of { I# n# ->
     case (newArray# n# init s#)     of { StateAndMutableArray# s2# arr# ->
-    (MutableArray ixs arr#, S# s2#)}}
+    STret s2# (MutableArray ixs arr#) }}
 
-newCharArray ixs = ST $ \ (S# s#) ->
+newCharArray ixs = ST $ \ s# ->
     case rangeSize ixs              of { I# n# ->
     case (newCharArray# n# s#)	  of { StateAndMutableByteArray# s2# barr# ->
-    (MutableByteArray ixs barr#, S# s2#)}}
+    STret s2# (MutableByteArray ixs barr#) }}
 
-newIntArray ixs = ST $ \ (S# s#) ->
+newIntArray ixs = ST $ \ s# ->
     case rangeSize ixs              of { I# n# ->
     case (newIntArray# n# s#)	  of { StateAndMutableByteArray# s2# barr# ->
-    (MutableByteArray ixs barr#, S# s2#)}}
+    STret s2# (MutableByteArray ixs barr#) }}
 
-newAddrArray ixs = ST $ \ (S# s#) ->
+newAddrArray ixs = ST $ \ s# ->
     case rangeSize ixs              of { I# n# ->
     case (newAddrArray# n# s#)	  of { StateAndMutableByteArray# s2# barr# ->
-    (MutableByteArray ixs barr#, S# s2#)}}
+    STret s2# (MutableByteArray ixs barr#) }}
 
-newFloatArray ixs = ST $ \ (S# s#) ->
+newFloatArray ixs = ST $ \ s# ->
     case rangeSize ixs              of { I# n# ->
     case (newFloatArray# n# s#)	  of { StateAndMutableByteArray# s2# barr# ->
-    (MutableByteArray ixs barr#, S# s2#)}}
+    STret s2# (MutableByteArray ixs barr#) }}
 
-newDoubleArray ixs = ST $ \ (S# s#) ->
+newDoubleArray ixs = ST $ \ s# ->
     case rangeSize ixs              of { I# n# ->
     case (newDoubleArray# n# s#)  of { StateAndMutableByteArray# s2# barr# ->
-    (MutableByteArray ixs barr#, S# s2#)}}
+    STret s2# (MutableByteArray ixs barr#) }}
 
 boundsOfArray     :: Ix ix => MutableArray s ix elt -> (ix, ix)  
 boundsOfByteArray :: Ix ix => MutableByteArray s ix -> (ix, ix)
@@ -245,35 +247,35 @@ readDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Double
 --NO:{-# SPECIALIZE readFloatArray  :: MutableByteArray s Int -> Int -> ST s Float #-}
 {-# SPECIALIZE readDoubleArray :: MutableByteArray s Int -> Int -> ST s Double #-}
 
-readArray (MutableArray ixs arr#) n = ST $ \ (S# s#) ->
+readArray (MutableArray ixs arr#) n = ST $ \ s# ->
     case (index ixs n)	    	of { I# n# ->
     case readArray# arr# n# s#	of { StateAndPtr# s2# r ->
-    (r, S# s2#)}}
+    STret s2# r }}
 
-readCharArray (MutableByteArray ixs barr#) n = ST $ \ (S# s#) ->
+readCharArray (MutableByteArray ixs barr#) n = ST $ \ s# ->
     case (index ixs n)	    	    	of { I# n# ->
     case readCharArray# barr# n# s#	of { StateAndChar# s2# r# ->
-    (C# r#, S# s2#)}}
+    STret s2# (C# r#) }}
 
-readIntArray (MutableByteArray ixs barr#) n = ST $ \ (S# s#) ->
+readIntArray (MutableByteArray ixs barr#) n = ST $ \ s# ->
     case (index ixs n)	    	    	of { I# n# ->
     case readIntArray# barr# n# s#	of { StateAndInt# s2# r# ->
-    (I# r#, S# s2#)}}
+    STret s2# (I# r#) }}
 
-readAddrArray (MutableByteArray ixs barr#) n = ST $ \ (S# s#) ->
+readAddrArray (MutableByteArray ixs barr#) n = ST $ \ s# ->
     case (index ixs n)	    	    	of { I# n# ->
     case readAddrArray# barr# n# s#	of { StateAndAddr# s2# r# ->
-    (A# r#, S# s2#)}}
+    STret s2# (A# r#) }}
 
-readFloatArray (MutableByteArray ixs barr#) n = ST $ \ (S# s#) ->
+readFloatArray (MutableByteArray ixs barr#) n = ST $ \ s# ->
     case (index ixs n)	    	    	of { I# n# ->
     case readFloatArray# barr# n# s#	of { StateAndFloat# s2# r# ->
-    (F# r#, S# s2#)}}
+    STret s2# (F# r#) }}
 
-readDoubleArray (MutableByteArray ixs barr#) n = ST $ \ (S# s#) ->
+readDoubleArray (MutableByteArray ixs barr#) n = ST $ \ s# ->
     case (index ixs n) 	    	    	of { I# n# ->
     case readDoubleArray# barr# n# s#	of { StateAndDouble# s2# r# ->
-    (D# r#, S# s2#)}}
+    STret s2# (D# r#) }}
 
 --Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here.
 indexCharArray   :: Ix ix => ByteArray ix -> ix -> Char 
@@ -361,35 +363,35 @@ writeDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> Double -> ST s ()
 --NO:{-# SPECIALIZE writeFloatArray  :: MutableByteArray s Int -> Int -> Float -> ST s () #-}
 {-# SPECIALIZE writeDoubleArray :: MutableByteArray s Int -> Int -> Double -> ST s () #-}
 
-writeArray (MutableArray ixs arr#) n ele = ST $ \ (S# s#) ->
+writeArray (MutableArray ixs arr#) n ele = ST $ \ s# ->
     case index ixs n		    of { I# n# ->
     case writeArray# arr# n# ele s# of { s2# ->
-    ((), S# s2#)}}
+    STret s2# () }}
 
-writeCharArray (MutableByteArray ixs barr#) n (C# ele) = ST $ \ (S# s#) ->
+writeCharArray (MutableByteArray ixs barr#) n (C# ele) = ST $ \ s# ->
     case (index ixs n)	    	    	    of { I# n# ->
     case writeCharArray# barr# n# ele s#    of { s2#   ->
-    ((), S# s2#)}}
+    STret s2# () }}
 
-writeIntArray (MutableByteArray ixs barr#) n (I# ele) = ST $ \ (S# s#) ->
+writeIntArray (MutableByteArray ixs barr#) n (I# ele) = ST $ \ s# ->
     case (index ixs n)	    	    	    of { I# n# ->
     case writeIntArray# barr# n# ele s#     of { s2#   ->
-    ((), S# s2#)}}
+    STret s2# () }}
 
-writeAddrArray (MutableByteArray ixs barr#) n (A# ele) = ST $ \ (S# s#) ->
+writeAddrArray (MutableByteArray ixs barr#) n (A# ele) = ST $ \ s# ->
     case (index ixs n)	    	    	    of { I# n# ->
     case writeAddrArray# barr# n# ele s#    of { s2#   ->
-    ((), S# s2#)}}
+    STret s2# () }}
 
-writeFloatArray (MutableByteArray ixs barr#) n (F# ele) = ST $ \ (S# s#) ->
+writeFloatArray (MutableByteArray ixs barr#) n (F# ele) = ST $ \ s# ->
     case (index ixs n)	    	    	    of { I# n# ->
     case writeFloatArray# barr# n# ele s#   of { s2#   ->
-    ((), S# s2#)}}
+    STret s2# () }}
 
-writeDoubleArray (MutableByteArray ixs barr#) n (D# ele) = ST $ \ (S# s#) ->
+writeDoubleArray (MutableByteArray ixs barr#) n (D# ele) = ST $ \ s# ->
     case (index ixs n)	    	    	    of { I# n# ->
     case writeDoubleArray# barr# n# ele s#  of { s2#   ->
-    ((), S# s2#)}}
+    STret s2# () }}
 \end{code}
 
 
@@ -412,10 +414,10 @@ freezeDoubleArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
   #-}
 {-# SPECIALISE freezeCharArray :: MutableByteArray s Int -> ST s (ByteArray Int) #-}
 
-freezeArray (MutableArray ixs arr#) = ST $ \ (S# s#) ->
+freezeArray (MutableArray ixs arr#) = ST $ \ s# ->
     case rangeSize ixs     of { I# n# ->
     case freeze arr# n# s# of { StateAndArray# s2# frozen# ->
-    (Array ixs frozen#, S# s2#)}}
+    STret s2# (Array ixs frozen#) }}
   where
     freeze  :: MutableArray# s ele	-- the thing
 	    -> Int#			-- size of thing to be frozen
@@ -444,10 +446,10 @@ freezeArray (MutableArray ixs arr#) = ST $ \ (S# s#) ->
 	      copy (cur# +# 1#) end# from# to# s2#
 	      }}
 
-freezeCharArray (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
+freezeCharArray (MutableByteArray ixs arr#) = ST $ \ s# ->
     case rangeSize ixs     of { I# n# ->
     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
-    (ByteArray ixs frozen#, S# s2#) }}
+    STret s2# (ByteArray ixs frozen#) }}
   where
     freeze  :: MutableByteArray# s	-- the thing
 	    -> Int#			-- size of thing to be frozen
@@ -474,10 +476,10 @@ freezeCharArray (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
 	      copy (cur# +# 1#) end# from# to# s2#
 	      }}
 
-freezeIntArray (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
+freezeIntArray (MutableByteArray ixs arr#) = ST $ \ s# ->
     case rangeSize ixs     of { I# n# ->
     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
-    (ByteArray ixs frozen#, S# s2#) }}
+    STret s2# (ByteArray ixs frozen#) }}
   where
     freeze  :: MutableByteArray# s	-- the thing
 	    -> Int#			-- size of thing to be frozen
@@ -504,10 +506,10 @@ freezeIntArray (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
 	      copy (cur# +# 1#) end# from# to# s2#
 	      }}
 
-freezeAddrArray (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
+freezeAddrArray (MutableByteArray ixs arr#) = ST $ \ s# ->
     case rangeSize ixs     of { I# n# ->
     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
-    (ByteArray ixs frozen#, S# s2#) }}
+    STret s2# (ByteArray ixs frozen#) }}
   where
     freeze  :: MutableByteArray# s	-- the thing
 	    -> Int#			-- size of thing to be frozen
@@ -534,10 +536,10 @@ freezeAddrArray (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
 	      copy (cur# +# 1#) end# from# to# s2#
 	      }}
 
-freezeFloatArray (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
+freezeFloatArray (MutableByteArray ixs arr#) = ST $ \ s# ->
     case rangeSize ixs     of { I# n# ->
     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
-    (ByteArray ixs frozen#, S# s2#) }}
+    STret s2# (ByteArray ixs frozen#) }}
   where
     freeze  :: MutableByteArray# s	-- the thing
 	    -> Int#			-- size of thing to be frozen
@@ -564,10 +566,10 @@ freezeFloatArray (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
 	      copy (cur# +# 1#) from# to# s2#
 	      }}
 
-freezeDoubleArray (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
+freezeDoubleArray (MutableByteArray ixs arr#) = ST $ \ s# ->
     case rangeSize ixs     of { I# n# ->
     case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
-    (ByteArray ixs frozen#, S# s2#) }}
+    STret s2# (ByteArray ixs frozen#) }}
   where
     freeze  :: MutableByteArray# s	-- the thing
 	    -> Int#			-- size of thing to be frozen
@@ -600,13 +602,13 @@ unsafeFreezeByteArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix)
 {-# SPECIALIZE unsafeFreezeByteArray :: MutableByteArray s Int -> ST s (ByteArray Int)
   #-}
 
-unsafeFreezeArray (MutableArray ixs arr#) = ST $ \ (S# s#) ->
+unsafeFreezeArray (MutableArray ixs arr#) = ST $ \ s# ->
     case unsafeFreezeArray# arr# s# of { StateAndArray# s2# frozen# ->
-    (Array ixs frozen#, S# s2#) }
+    STret s2# (Array ixs frozen#) }
 
-unsafeFreezeByteArray (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
+unsafeFreezeByteArray (MutableByteArray ixs arr#) = ST $ \ s# ->
     case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
-    (ByteArray ixs frozen#, S# s2#) }
+    STret s2# (ByteArray ixs frozen#) }
 
 
 --This takes a immutable array, and copies it into a mutable array, in a
@@ -617,10 +619,10 @@ unsafeFreezeByteArray (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
   #-}
 
 thawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt)
-thawArray (Array ixs arr#) = ST $ \ (S# s#) ->
+thawArray (Array ixs arr#) = ST $ \ s# ->
     case rangeSize ixs     of { I# n# ->
     case thaw arr# n# s# of { StateAndMutableArray# s2# thawed# ->
-    (MutableArray ixs thawed#, S# s2#)}}
+    STret s2# (MutableArray ixs thawed#)}}
   where
     thaw  :: Array# ele			-- the thing
 	    -> Int#			-- size of thing to be thawed
diff --git a/ghc/lib/ghc/ConcBase.lhs b/ghc/lib/ghc/ConcBase.lhs
index 2efd689787b8f9e63cdc9cb7e869a45cf301f00f..81f27240bde368e5b59d19b75f4ed5697c708b7c 100644
--- a/ghc/lib/ghc/ConcBase.lhs
+++ b/ghc/lib/ghc/ConcBase.lhs
@@ -21,8 +21,8 @@ module ConcBase(
     ) where
 
 import PrelBase
-import STBase	( PrimIO(..), ST(..), State(..), StateAndPtr#(..) )
-import IOBase	( IO(..), MVar(..) )
+import STBase	( PrimIO(..), ST(..), STret(..), StateAndPtr#(..) )
+import IOBase	( IO(..), IOResult(..), MVar(..) )
 import GHCerr	( parError )
 import PrelBase	( Int(..) )
 import GHC	( fork#, delay#, waitRead#, waitWrite#,
@@ -44,21 +44,15 @@ infixr 0 `par`, `fork`
 \begin{code}
 forkST :: ST s a -> ST s a
 
-forkST (ST action) = ST $ \ s ->
-   let
-    (r, new_s) = action s
-   in
-    new_s `fork` (r, s)
+forkST (ST action) = ST $ \ s -> 
+	let d@(STret _ r) = action s in
+	d `fork` STret s r
 
 forkPrimIO :: PrimIO a -> PrimIO a
 forkPrimIO = forkST
 
 forkIO :: IO () -> IO ()
-forkIO (IO (ST action)) = IO $ ST $ \ s ->
-    let
-	(_, new_s) = action s
-    in
-    new_s `fork` (Right (), s)
+forkIO (IO action) = IO $ \ s -> (action s) `fork` IOok s ()
 
 par, fork :: Eval a => a -> b -> b
 
@@ -98,21 +92,21 @@ writes.
 
 newEmptyMVar  :: IO (MVar a)
 
-newEmptyMVar = IO $ ST $ \ (S# s#) ->
+newEmptyMVar = IO $ \ s# ->
     case newSynchVar# s# of
-        StateAndSynchVar# s2# svar# -> (Right (MVar svar#), S# s2#)
+        StateAndSynchVar# s2# svar# -> IOok s2# (MVar svar#)
 
 takeMVar :: MVar a -> IO a
 
-takeMVar (MVar mvar#) = IO $ ST $ \ (S# s#) ->
+takeMVar (MVar mvar#) = IO $ \ s# ->
     case takeMVar# mvar# s# of
-        StateAndPtr# s2# r -> (Right r, S# s2#)
+        StateAndPtr# s2# r -> IOok s2# r
 
 putMVar  :: MVar a -> a -> IO ()
 
-putMVar (MVar mvar#) x = IO $ ST $ \ (S# s#) ->
+putMVar (MVar mvar#) x = IO $ \ s# ->
     case putMVar# mvar# x s# of
-        s2# -> (Right (), S# s2#)
+        s2# -> IOok s2# ()
 
 newMVar :: a -> IO (MVar a)
 
@@ -158,17 +152,17 @@ specified file descriptor is available for reading (just like select).
 \begin{code}
 threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
 
-threadDelay (I# x#) = IO $ ST $ \ (S# s#) ->
+threadDelay (I# x#) = IO $ \ s# ->
     case delay# x# s# of
-      s2# -> (Right (), S# s2#)
+      s2# -> IOok s2# ()
 
-threadWaitRead (I# x#) = IO $ ST $ \ (S# s#) -> 
+threadWaitRead (I# x#) = IO $ \ s# -> 
     case waitRead# x# s# of
-      s2# -> (Right (), S# s2#)
+      s2# -> IOok s2# ()
 
-threadWaitWrite (I# x#) = IO $ ST $ \ (S# s#) ->
+threadWaitWrite (I# x#) = IO $ \ s# ->
     case waitWrite# x# s# of
-      s2# -> (Right (), S# s2#)
+      s2# -> IOok s2# ()
 \end{code}
 
 %*********************************************************
diff --git a/ghc/lib/ghc/GHCmain.lhs b/ghc/lib/ghc/GHCmain.lhs
index 6581c577985b59822892ac1a3f259d6cf47a6d6f..a030899bb594470eb2130c62e818e5f71e1f11f0 100644
--- a/ghc/lib/ghc/GHCmain.lhs
+++ b/ghc/lib/ghc/GHCmain.lhs
@@ -13,12 +13,11 @@ import STBase
 
 \begin{code}
 mainPrimIO = ST $ \ s ->
-    case Main.main   of { IO (ST main_guts) ->
-    case main_guts s of { (result, s2@(S# _)) ->
-    case result   of
-      Right ()  -> ( (), s2 )
-      Left  err -> error ("I/O error: "++showsPrec 0 err "\n")
-    }}
+    case Main.main   of { IO main_guts ->
+    case main_guts s of
+	IOok   s2 ()  -> STret s2 ()
+      	IOfail s2 err -> error ("I/O error: "++showsPrec 0 err "\n")
+    }
 \end{code}
 
 OLD COMMENT:
diff --git a/ghc/lib/ghc/IOBase.lhs b/ghc/lib/ghc/IOBase.lhs
index 47015c375f792d469c7db7499164155af67c598d..9121dfcf96768ffa77f8718be0a092ff9dff9d7e 100644
--- a/ghc/lib/ghc/IOBase.lhs
+++ b/ghc/lib/ghc/IOBase.lhs
@@ -33,8 +33,19 @@ infixr 1 `thenIO_Prim`, `seqIO_Prim`
 %*							*
 %*********************************************************
 
+IO is no longer built on top of PrimIO (which is a specialised version
+of the ST monad), instead it is now has its own type.  This is purely
+for efficiency purposes, since we get to remove several levels of
+lifting in the type of the monad.
+
 \begin{code}
-newtype IO a = IO (PrimIO (Either IOError a))
+newtype IO a = IO (State# RealWorld -> IOResult a)
+
+{-# INLINE unIO #-}
+unIO (IO a) = a
+
+data IOResult a = IOok   (State# RealWorld) a
+		| IOfail (State# RealWorld) IOError
 
 instance  Functor IO where
    map f x = x >>= (return . f)
@@ -44,40 +55,36 @@ instance  Monad IO  where
     {-# INLINE (>>)   #-}
     {-# INLINE (>>=)  #-}
     m >> k      =  m >>= \ _ -> k
-    return x	= IO $ ST $ \ s@(S# _) -> (Right x, s)
+    return x	= IO $ \ s -> IOok s x
 
-    (IO (ST m)) >>= k =
-        IO (ST ( \ s ->
-	let  (r, new_s) = m s  in
-	case r of
-	  Left err -> (Left err, new_s)
-	  Right  x -> case (k x) of { IO (ST k2) ->
-		        k2 new_s }))
+    (IO m) >>= k =
+        IO $ \s ->
+	case m s of
+	    IOfail new_s err -> IOfail new_s err
+	    IOok   new_s a   -> unIO (k a) new_s
 
 fixIO :: (a -> IO a) -> IO a
     -- not required but worth having around
 
-fixIO k = IO $ ST $ \ s ->
+fixIO k = IO $ \ s ->
     let
-	(IO (ST k_loop)) = k loop
-	result           = k_loop s
-	(Right loop, _)  = result
+	(IO k_loop) = k loop
+	result      = k_loop s
+	IOok _ loop = result
     in
     result
 
 fail            :: IOError -> IO a 
-fail err	=  IO $ ST $ \ s -> (Left err, s)
+fail err	=  IO $ \ s -> IOfail s err
 
 userError       :: String  -> IOError
 userError str	=  IOError Nothing UserError str
 
 catch           :: IO a    -> (IOError -> IO a) -> IO a 
-catch (IO (ST m)) k  = IO $ ST $ \ s ->
-  case (m s) of { (r, new_s) ->
-  case r of
-    Right  _ -> (r, new_s)
-    Left err -> case (k err) of { IO (ST k_err) ->
-		(k_err new_s) }}
+catch (IO m) k  = IO $ \ s ->
+  case m s of
+    IOok   new_s a -> IOok new_s a
+    IOfail new_s e -> unIO (k e) new_s
 
 instance  Show (IO a)  where
     showsPrec p f  = showString "<<IO action>>"
@@ -99,16 +106,12 @@ ioToPrimIO :: IO a -> PrimIO       a
 primIOToIO = stToIO -- for backwards compatibility
 ioToPrimIO = ioToST
 
-stToIO (ST m) = IO $ ST $ \ s ->
-    case (m s) of { (r, new_s) ->
-    (Right r, new_s) }
+stToIO (ST m) = IO $ \ s -> case (m s) of STret new_s r -> IOok new_s r
 
-ioToST (IO (ST io)) = ST $ \ s ->
-    case (io s) of { (r, new_s) ->
-    case r of
-      Right a -> (a, new_s)
-      Left  e -> error ("I/O Error (ioToST): " ++ showsPrec 0 e "\n")
-    }
+ioToST (IO io) = ST $ \ s ->
+    case (io s) of
+      IOok   new_s a -> STret new_s a
+      IOfail new_s e -> error ("I/O Error (ioToST): " ++ showsPrec 0 e "\n")
 \end{code}
 
 @thenIO_Prim@ is a useful little number for doing _ccall_s in IO-land:
@@ -119,10 +122,8 @@ seqIO_Prim  :: PrimIO a -> IO b -> IO b
 {-# INLINE thenIO_Prim   #-}
 {-# INLINE seqIO_Prim   #-}
 
-thenIO_Prim (ST m) k = IO $ ST $ \ s ->
-    case (m s)     of { (m_res, new_s)    ->
-    case (k m_res) of { (IO (ST k_m_res)) ->
-    k_m_res new_s }}
+thenIO_Prim (ST m) k = IO $ \ s ->
+    case (m s) of STret new_s m_res -> unIO (k m_res) new_s
 
 seqIO_Prim m k = thenIO_Prim m (\ _ -> k)
 \end{code}
diff --git a/ghc/lib/ghc/PackBase.lhs b/ghc/lib/ghc/PackBase.lhs
index e3011340464a0474085b4a017a62c09d6abf97c5..1388329484830dc020d2555f3b284bf1826f98e0 100644
--- a/ghc/lib/ghc/PackBase.lhs
+++ b/ghc/lib/ghc/PackBase.lhs
@@ -248,20 +248,20 @@ new_ps_array	:: Int# -> ST s (MutableByteArray s Int)
 write_ps_array	:: MutableByteArray s Int -> Int# -> Char# -> ST s () 
 freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
 
-new_ps_array size = ST $ \ (S# s) ->
+new_ps_array size = ST $ \ s ->
     case (newCharArray# size s)	  of { StateAndMutableByteArray# s2# barr# ->
-    (MutableByteArray bot barr#, S# s2#)}
+    STret s2# (MutableByteArray bot barr#) }
   where
     bot = error "new_ps_array"
 
-write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ (S# s#) ->
+write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
     case writeCharArray# barr# n ch s#	of { s2#   ->
-    ((), S# s2#)}
+    STret s2# () }
 
 -- same as unsafeFreezeByteArray
-freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ (S# s#) ->
+freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
     case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
-    (ByteArray (0,I# len#) frozen#, S# s2#) }
+    STret s2# (ByteArray (0,I# len#) frozen#) }
 \end{code}
 
 
diff --git a/ghc/lib/ghc/STBase.lhs b/ghc/lib/ghc/STBase.lhs
index 9477be0f8ed9381775bd24713dc4c837087e6028..e8d353b584d4776f109e745fb127f42a2b2d0209 100644
--- a/ghc/lib/ghc/STBase.lhs
+++ b/ghc/lib/ghc/STBase.lhs
@@ -23,23 +23,24 @@ The state-transformer monad proper.  By default the monad is strict;
 too many people got bitten by space leaks when it was lazy.
 
 \begin{code}
-data State a   = S# (State# a)
-newtype ST s a = ST (State s -> (a, State s))
+newtype ST s a = ST (State# s -> STret s a)
+
+data STret s a = STret (State# s) a
 
 runST (ST m)
-  = case m (S# realWorld#) of
-      (r,_) -> r
+  = case m realWorld# of
+      STret _ r -> r
 
 instance Monad (ST s) where
     {-# INLINE return #-}
     {-# INLINE (>>)   #-}
     {-# INLINE (>>=)  #-}
-    return x = ST $ \ s@(S# _) -> (x, s)
+    return x = ST $ \ s -> STret s x
     m >> k   =  m >>= \ _ -> k
 
     (ST m) >>= k
       = ST $ \ s ->
-	case (m s) of {(r, new_s) ->
+	case (m s) of { STret new_s r ->
 	case (k r) of { ST k2 ->
 	(k2 new_s) }}
 
@@ -60,7 +61,7 @@ fixST :: (a -> ST s a) -> ST s a
 fixST k = ST $ \ s ->
     let (ST k_r)  = k r
 	ans       = k_r s
-	(r,new_s) = ans
+	STret _ r = ans
     in
     ans
 
@@ -122,7 +123,12 @@ mapAndUnzipPrimIO = mapAndUnzipM
 %*							*
 %*********************************************************
 
+The @State@ type is the return type of a _ccall_ with no result.  It
+never actually exists, since it's always deconstructed straight away;
+the desugarer ensures this.
+
 \begin{code}
+data State	     s     = S#		     (State# s)
 data StateAndPtr#    s elt = StateAndPtr#    (State# s) elt 
 
 data StateAndChar#   s     = StateAndChar#   (State# s) Char# 
diff --git a/ghc/lib/ghc/UnsafeST.lhs b/ghc/lib/ghc/UnsafeST.lhs
index f185990cb62d908def773657b9d39b2bcbf81801..5f7268d6debba28cc7b061c9aa459283a26a4a0e 100644
--- a/ghc/lib/ghc/UnsafeST.lhs
+++ b/ghc/lib/ghc/UnsafeST.lhs
@@ -28,16 +28,16 @@ import GHC
 unsafeInterleaveST :: ST s a -> ST s a
 unsafeInterleaveST (ST m) = ST ( \ s ->
     let
-	(r, new_s) = m s
+	STret _ r = m s
     in
-    (r, s))
+    STret s r)
 
 unsafePerformPrimIO	:: PrimIO a -> a
 	-- We give a fresh definition here.  There are no
 	-- magical universal types kicking around.
 unsafePerformPrimIO (ST m)
-  = case m (S# realWorld#) of
-      (r,_) -> r
+  = case m realWorld# of
+      STret _ r -> r
 
 unsafeInterleavePrimIO	:: PrimIO a -> PrimIO a
 unsafeInterleavePrimIO	= unsafeInterleaveST
diff --git a/ghc/lib/glaExts/Foreign.lhs b/ghc/lib/glaExts/Foreign.lhs
index 4285e7855239d5d47f91ffd19e6be40cc434d8d2..d72e31454b8ac6dedf0fe3f81b6b46a7a4f24d2f 100644
--- a/ghc/lib/glaExts/Foreign.lhs
+++ b/ghc/lib/glaExts/Foreign.lhs
@@ -88,12 +88,12 @@ writeForeignObj :: ForeignObj  -> Addr       -> PrimIO ()
 {- derived op - attaching a free() finaliser to a malloc() allocated reference. -}
 makeMallocPtr   :: Addr        -> PrimIO ForeignObj
 
-makeForeignObj (A# obj) (A# finaliser) = ST ( \ (S# s#) ->
+makeForeignObj (A# obj) (A# finaliser) = ST ( \ s# ->
     case makeForeignObj# obj finaliser s# of
-      StateAndForeignObj# s1# fo# -> (ForeignObj fo#, S# s1#))
+      StateAndForeignObj# s1# fo# -> STret s1# (ForeignObj fo#))
 
-writeForeignObj (ForeignObj fo#) (A# datum#) = ST ( \ (S# s#) ->
-    case writeForeignObj# fo# datum# s# of { s1# -> ((), S# s1#) } )
+writeForeignObj (ForeignObj fo#) (A# datum#) = ST ( \ s# ->
+    case writeForeignObj# fo# datum# s# of { s1# -> STret s1# () } )
 
 makeMallocPtr a = makeForeignObj a (``&free''::Addr)
 
@@ -133,13 +133,13 @@ performGC      :: PrimIO ()
 {-# INLINE freeStablePtr #-}
 {-# INLINE performGC #-}
 
-makeStablePtr f = ST $ \ (S# rw1#) ->
+makeStablePtr f = ST $ \ rw1# ->
     case makeStablePtr# f rw1# of
-      StateAndStablePtr# rw2# sp# -> (StablePtr sp#, S# rw2#)
+      StateAndStablePtr# rw2# sp# -> STret rw2# (StablePtr sp#)
 
-deRefStablePtr (StablePtr sp#) = ST $ \ (S# rw1#) ->
+deRefStablePtr (StablePtr sp#) = ST $ \ rw1# ->
     case deRefStablePtr# sp# rw1# of
-      StateAndPtr# rw2# a -> (a, S# rw2#)
+      StateAndPtr# rw2# a -> STret rw2# a
 
 freeStablePtr sp = _ccall_ freeStablePointer sp
 
diff --git a/ghc/lib/glaExts/ST.lhs b/ghc/lib/glaExts/ST.lhs
index 4e0d6b9480e00612afe92aa818faf7086ae68d3d..d25dc83dfbaa1bfb7f52270beacc1db21789de8a 100644
--- a/ghc/lib/glaExts/ST.lhs
+++ b/ghc/lib/glaExts/ST.lhs
@@ -20,7 +20,7 @@ module ST (
 	thenST, seqST, returnST, listST, fixST, runST, unsafeInterleaveST,
         mapST, mapAndUnzipST,
          -- the lazy variant
-	returnLazyST, thenLazyST, seqLazyST,
+	-- returnLazyST, thenLazyST, seqLazyST,
 
 	MutableVar,
 	newVar, readVar, writeVar, sameVar,
@@ -54,19 +54,19 @@ readVar  :: MutableVar s a -> ST s a
 writeVar :: MutableVar s a -> a -> ST s ()
 sameVar  :: MutableVar s a -> MutableVar s a -> Bool
 
-newVar init = ST $ \ (S# s#) ->
+newVar init = ST $ \ s# ->
     case (newArray# 1# init s#)     of { StateAndMutableArray# s2# arr# ->
-    (MutableArray vAR_IXS arr#, S# s2#) }
+    STret s2# (MutableArray vAR_IXS arr#) }
   where
     vAR_IXS = error "newVar: Shouldn't access `bounds' of a MutableVar\n"
 
-readVar (MutableArray _ var#) = ST $ \ (S# s#) ->
+readVar (MutableArray _ var#) = ST $ \ s# ->
     case readArray# var# 0# s#	of { StateAndPtr# s2# r ->
-    (r, S# s2#) }
+    STret s2# r }
 
-writeVar (MutableArray _ var#) val = ST $ \ (S# s#) ->
+writeVar (MutableArray _ var#) val = ST $ \ s# ->
     case writeArray# var# 0# val s# of { s2# ->
-    ((), S# s2#) }
+    STret s2# () }
 
 sameVar (MutableArray _ var1#) (MutableArray _ var2#)
   = sameMutableArray# var1# var2#
@@ -83,31 +83,3 @@ sameMutableArray (MutableArray _ arr1#) (MutableArray _ arr2#)
 sameMutableByteArray (MutableByteArray _ arr1#) (MutableByteArray _ arr2#)
   = sameMutableByteArray# arr1# arr2#
 \end{code}
-
-Lazy monad combinators, the @Monad@ instance for @ST@
-uses the strict variant:
-
-\begin{code}
-returnLazyST :: a -> ST s a
-returnLazyST a = ST (\ s -> (a, s))
-
-thenLazyST :: ST s a -> (a -> ST s b) -> ST s b
-thenLazyST m k
- = ST $ \ s ->
-   let 
-     (ST m_a) = m
-     (r, new_s) = m_a s
-     (ST k_a) = k r
-   in  
-   k_a new_s
-
-seqLazyST :: ST s a -> ST s b -> ST s b
-seqLazyST m k
- = ST $ \ s ->
-   let
-    (ST m_a) = m
-    (_, new_s) = m_a s
-    (ST k_a) = k
-   in  
-   k_a new_s
-\end{code}
diff --git a/ghc/lib/required/Directory.lhs b/ghc/lib/required/Directory.lhs
index 69c81f3a17f1d4c3e96f44c13c94c61ebc034a15..719fe8be404054ceb8f6c8a7d8181dbcfa202dff 100644
--- a/ghc/lib/required/Directory.lhs
+++ b/ghc/lib/required/Directory.lhs
@@ -501,9 +501,10 @@ modificationTime stat =
     cvtUnsigned i1                                         `thenIO_Prim` \ secs ->
     return (TOD secs 0)
   where
-    malloc1 = ST $ \ (S# s#) ->
+    malloc1 = ST $ \ s# ->
 	case newIntArray# 1# s# of 
-          StateAndMutableByteArray# s2# barr# -> (MutableByteArray bnds barr#, S# s2#)
+          StateAndMutableByteArray# s2# barr# -> 
+		STret s2# (MutableByteArray bnds barr#)
 
     bnds = (0,1)
     -- The C routine fills in an unsigned word.  We don't have `unsigned2Integer#,'
@@ -511,14 +512,15 @@ modificationTime stat =
     -- zero is still handled specially, although (J# 1# 1# (ptr to 0#)) is probably
     -- acceptable to gmp.
 
-    cvtUnsigned (MutableByteArray _ arr#) = ST $ \ (S# s#) ->
+    cvtUnsigned (MutableByteArray _ arr#) = ST $ \ s# ->
 	case readIntArray# arr# 0# s# of 
 	  StateAndInt# s2# r# ->
             if r# ==# 0# then
-                (0, S# s2#)
+                STret s2# 0
             else
                 case unsafeFreezeByteArray# arr# s2# of
-                  StateAndByteArray# s3# frozen# -> (J# 1# 1# frozen#, S# s3#)
+                  StateAndByteArray# s3# frozen# -> 
+			STret s3# (J# 1# 1# frozen#)
 
 isDirectory :: FileStatus -> Bool
 isDirectory stat = unsafePerformPrimIO $
diff --git a/ghc/lib/required/IO.lhs b/ghc/lib/required/IO.lhs
index 407e261a011601a99491df8ae258beba1938e201..87b4116fa3b12cea8958566c689214ed89302b7a 100644
--- a/ghc/lib/required/IO.lhs
+++ b/ghc/lib/required/IO.lhs
@@ -533,9 +533,9 @@ hPutStr handle str =
      newCharArray (0,I# bufLen) >>= \ arr@(MutableByteArray _ arr#) ->
      let
       write_char :: MutableByteArray# RealWorld -> Int# -> Char# -> PrimIO ()
-      write_char arr# n x = ST $ \ (S# s#) ->
+      write_char arr# n x = ST $ \ s# ->
 	  case (writeCharArray# arr# n x s#) of { s1# ->
-	  ( (), S# s1# ) }
+	  STret s1# () }
 
       shoveString :: Int# -> [Char] -> PrimIO Bool
       shoveString n ls = 
diff --git a/ghc/lib/required/Time.lhs b/ghc/lib/required/Time.lhs
index 26920d0d30c2ffbca73e380449ed25f919a46dd5..de9fad98f2e367d4a2a8633a08e35820ca83cf70 100644
--- a/ghc/lib/required/Time.lhs
+++ b/ghc/lib/required/Time.lhs
@@ -157,23 +157,25 @@ getClockTime =
     else
 	constructErrorAndFail "getClockTime"
   where
-    malloc1 = ST $ \ (S# s#) ->
+    malloc1 = ST $ \ s# ->
 	case newIntArray# 1# s# of 
-          StateAndMutableByteArray# s2# barr# -> (MutableByteArray bottom barr#, S# s2#)
+          StateAndMutableByteArray# s2# barr# -> 
+		STret s2# (MutableByteArray bottom barr#)
 
-    -- The C routine fills in an unsigned word.  We don't have `unsigned2Integer#,'
-    -- so we freeze the data bits and use them for an MP_INT structure.  Note that
-    -- zero is still handled specially, although (J# 1# 1# (ptr to 0#)) is probably
-    -- acceptable to gmp.
+    --  The C routine fills in an unsigned word.  We don't have 
+    --	`unsigned2Integer#,' so we freeze the data bits and use them 
+    --	for an MP_INT structure.  Note that zero is still handled specially,
+    --	although (J# 1# 1# (ptr to 0#)) is probably acceptable to gmp.
 
-    cvtUnsigned (MutableByteArray _ arr#) = ST $ \ (S# s#) ->
+    cvtUnsigned (MutableByteArray _ arr#) = ST $ \ s# ->
 	case readIntArray# arr# 0# s# of 
 	  StateAndInt# s2# r# ->
             if r# ==# 0# then
-                (0, S# s2#)
+                STret s2# 0
             else
                 case unsafeFreezeByteArray# arr# s2# of
-                  StateAndByteArray# s3# frozen# -> (J# 1# 1# frozen#, S# s3#)
+                  StateAndByteArray# s3# frozen# -> 
+			STret s3# (J# 1# 1# frozen#)
 
 \end{code}
 
@@ -300,18 +302,20 @@ bottom = error "Time.bottom"
 -- Allocate a mutable array of characters with no indices.
 
 allocChars :: Int -> ST s (MutableByteArray s ())
-allocChars (I# size#) = ST $ \ (S# s#) ->
+allocChars (I# size#) = ST $ \ s# ->
     case newCharArray# size# s# of 
-      StateAndMutableByteArray# s2# barr# -> (MutableByteArray bot barr#, S# s2#)
+      StateAndMutableByteArray# s2# barr# -> 
+	STret s2# (MutableByteArray bot barr#)
   where
     bot = error "Time.allocChars"
 
 -- Allocate a mutable array of words with no indices
 
 allocWords :: Int -> ST s (MutableByteArray s ())
-allocWords (I# size#) = ST $ \ (S# s#) ->
+allocWords (I# size#) = ST $ \ s# ->
     case newIntArray# size# s# of 
-      StateAndMutableByteArray# s2# barr# -> (MutableByteArray bot barr#, S# s2#)
+      StateAndMutableByteArray# s2# barr# -> 
+	STret s2# (MutableByteArray bot barr#)
   where
     bot = error "Time.allocWords"
 
diff --git a/ghc/runtime/c-as-asm/PerformIO.lhc b/ghc/runtime/c-as-asm/PerformIO.lhc
index 1296c1f4f06d83a37f2c9a2a0a9cc30195770a51..04fd72dc557b50826d7b0966f99889432e865475 100644
--- a/ghc/runtime/c-as-asm/PerformIO.lhc
+++ b/ghc/runtime/c-as-asm/PerformIO.lhc
@@ -80,7 +80,7 @@ const W_ vtbl_stopPerformIO[] = {
    has gotten hold of (hopefully via @MakeStablePtr#@).
 */
 P_ unstable_Closure;
-ED_RO_(WorldStateToken_closure);
+ED_RO_(realWorldZh_closure);
 
 STGFUN(startPerformIO)
 {
@@ -118,7 +118,7 @@ STGFUN(startPerformIO)
     /* Put a World State Token on the A stack */
     /* This is necessary because we've not unboxed it (to reveal a void) yet */
     SpA -= AREL(1);
-    *SpA = (P_) WorldStateToken_closure;
+    *SpA = (P_) realWorldZh_closure;
 
     /* Save away C stack pointer so that we can restore it when we leave
        the Haskell world.
diff --git a/ghc/runtime/main/StgStartup.lhc b/ghc/runtime/main/StgStartup.lhc
index e0f26a73d115dab173a2b6589c95ba8b3b165815..61d963bc0a6c34174eba390074113241e66b8462 100644
--- a/ghc/runtime/main/StgStartup.lhc
+++ b/ghc/runtime/main/StgStartup.lhc
@@ -200,10 +200,6 @@ SET_STATIC_HDR(EmptySPTable_closure,EmptyStablePointerTable_info,CC_SUBSUMED,,ED
 P_ realWorldZh_closure = (P_) 0xbadbadbaL;
 P_ GHC_void_closure = (P_) 0xbadbadbaL;
 
-SET_STATIC_HDR(WorldStateToken_closure,STBase_SZh_static_info,CC_SUBSUMED/*harmless*/,,ED_RO_)
-, (W_) 0xbadbadbaL
-};
-
 #ifndef CONCURRENT
 
 STGFUN(startStgWorld)
@@ -226,8 +222,8 @@ STGFUN(startStgWorld)
     RetReg = (StgRetAddr) UNVEC(stopThreadDirectReturn,vtbl_stopStgWorld); 
 
     /* Put an IoWorld token on the A stack */
-    SpA -= AREL(1);
-    *SpA = (P_) WorldStateToken_closure;
+    SpB -= BREL(1);
+    *SpB = (P_) realWorldZh_closure;
 
     Node = (P_) TopClosure; /* Point to the closure for main/errorIO-arg */
     ENT_VIA_NODE();
@@ -361,7 +357,7 @@ STGFUN(ErrorIO_innards)
 
     SpA = SuA - AREL(1);
 
-    *SpA = (P_) WorldStateToken_closure;
+    *SpA = (P_) realWorldZh_closure;
 
     STKO_LINK(StkOReg) = PrelBase_Z91Z93_closure;
     STKO_RETURN(StkOReg) = NULL;
diff --git a/ghc/runtime/main/Threads.lc b/ghc/runtime/main/Threads.lc
index d3abc811b23dd3f2c37f9efb8a8ee5a3d7ecf64e..51a48fbfa0ac59d73a7588070d1c35d9bd951e16 100644
--- a/ghc/runtime/main/Threads.lc
+++ b/ghc/runtime/main/Threads.lc
@@ -2216,7 +2216,7 @@ processor:
 \begin{code}
 EXTDATA_RO(StkO_info);
 EXTDATA_RO(TSO_info);
-EXTDATA_RO(WorldStateToken_closure);
+EXTDATA_RO(realWorldZh_closure);
 
 EXTFUN(EnterNodeCode);
 UNVEC(EXTFUN(stopThreadDirectReturn);,EXTDATA(vtbl_stopStgWorld);)
@@ -2565,7 +2565,7 @@ W_ type;
 
     if (type == T_MAIN) {
         STKO_SpA(stko) -= AREL(1);
-        *STKO_SpA(stko) = (P_) WorldStateToken_closure;
+        *STKO_SpA(stko) = (P_) realWorldZh_closure;
     }
 
     SAVE_Ret = (StgRetAddr) UNVEC(stopThreadDirectReturn,vtbl_stopStgWorld);
diff --git a/ghc/tests/codeGen/should_run/cg025.stderr b/ghc/tests/codeGen/should_run/cg025.stderr
index 1be826f193e71d32868aede740007f6e69445139..8caaaca00a7c203eceeed48564b29d011e986474 100644
--- a/ghc/tests/codeGen/should_run/cg025.stderr
+++ b/ghc/tests/codeGen/should_run/cg025.stderr
@@ -1,6 +1,6 @@
 "cg025.bin"
 ["cg025.hs"]
-"/bin:/usr/bin:/users/ets/simonm/bin:/users/ets/simonm/bin/i386-unknown-freebsd2.2:/usr/local/bin:/usr/X11R6/bin:/usr/local/X11R6/bin:/local/fp/bin:/local/fp/bin/i386-unknown-freebsd2.2:/local/ets/go/i386-unknown-freebsd2.2:/local/fp/bin/i386-unknown-freebsd2.1.0:/local/ets/go/i386-unknown-freebsd2.1.0:/usr/local/teTeX/bin:/sbin:/usr/sbin"
+"/bin:/usr/bin:/users/ets/simonm/bin:/users/ets/simonm/bin/i386-unknown-freebsd:/usr/local/bin:/sbin:/usr/sbin:/usr/X11R6/bin:/usr/local/X11R6/bin:/local/fp/bin:/local/fp/bin/i386-unknown-freebsd:/local/ets/go/i386-unknown-freebsd:/usr/local/teTeX/bin"
 --!!! test various I/O Requests
 --
 --