From df10403c92440a304198b3096e65d52a1fe482ae Mon Sep 17 00:00:00 2001 From: simonm Date: Mon, 13 Oct 1997 16:20:10 +0000 Subject: [PATCH] [project @ 1997-10-13 16:12:54 by simonm] Changes to unbox the state in the ST and IO monads. ST now has type newtype ST s a = ST (State# s -> STret s a) data STret s a = STret (State# s) a IO now has type newtype IO a = IO (State# RealWorld -> IOResult a) data IOResult a = IOok (State# RealWorld) a | IOfail (State# RealWorld) IOError So ST should be slightly more efficient, and IO should be nearly as efficient as ST. --- ghc/compiler/basicTypes/Unique.lhs | 4 + ghc/compiler/deSugar/DsCCall.lhs | 40 +++++----- ghc/compiler/prelude/PrelInfo.lhs | 2 +- ghc/compiler/prelude/PrimOp.lhs | 2 +- ghc/compiler/prelude/TysWiredIn.lhs | 17 +++- ghc/compiler/simplCore/SimplUtils.lhs | 1 - ghc/compiler/simplCore/Simplify.lhs | 6 +- ghc/driver/ghc-asm.lprl | 1 - ghc/driver/ghc.lprl | 1 - ghc/lib/concurrent/Channel.lhs | 33 ++------ ghc/lib/ghc/ArrBase.lhs | 124 +++++++++++++++-------------- ghc/lib/ghc/ConcBase.lhs | 42 +++++----- ghc/lib/ghc/GHCmain.lhs | 11 ++- ghc/lib/ghc/IOBase.lhs | 67 ++++++++-------- ghc/lib/ghc/PackBase.lhs | 12 +-- ghc/lib/ghc/STBase.lhs | 20 +++-- ghc/lib/ghc/UnsafeST.lhs | 8 +- ghc/lib/glaExts/Foreign.lhs | 16 ++-- ghc/lib/glaExts/ST.lhs | 42 ++-------- ghc/lib/required/Directory.lhs | 12 +-- ghc/lib/required/IO.lhs | 4 +- ghc/lib/required/Time.lhs | 30 ++++--- ghc/runtime/c-as-asm/PerformIO.lhc | 4 +- ghc/runtime/main/StgStartup.lhc | 10 +-- ghc/runtime/main/Threads.lc | 4 +- ghc/tests/codeGen/should_run/cg025.stderr | 2 +- 26 files changed, 246 insertions(+), 269 deletions(-) diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 9aa57b9..17c9d57 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 15758da..4d3e3ed 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 5b84197..7abfbab 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 d02fe6d..ab2428c 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 c66d215..e689b53 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, @@ -284,6 +287,18 @@ stateDataCon \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") alpha_tyvar [stablePtrDataCon] @@ -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 4a9e8a8..7997378 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 91e1c77..b08bd2a 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 06a6416..8c99b70 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 ea27869..78070dc 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 417e139..7bf6d18 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 cee229d..c736fed 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 2efd689..81f2724 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 6581c57..a030899 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 47015c3..9121dfc 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 "<>" @@ -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 e301134..1388329 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 9477be0..e8d353b 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 f185990..5f7268d 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 4285e78..d72e314 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 4e0d6b9..d25dc83 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 69c81f3..719fe8b 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 407e261..87b4116 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 26920d0..de9fad9 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 1296c1f..04fd72d 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 e0f26a7..61d963b 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 d3abc81..51a48fb 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 1be826f..8caaaca 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 -- -- -- 1.7.10.4