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.
stateAndWordPrimDataConKey,
stateAndWordPrimTyConKey,
stateDataConKey,
+ stRetDataConKey,
statePrimTyConKey,
stateTyConKey,
+ stRetTyConKey,
synchVarPrimTyConKey,
thenMClassOpKey,
toEnumClassOpKey,
wordPrimTyConKey = mkPreludeTyConUnique 53
wordTyConKey = mkPreludeTyConUnique 54
voidTyConKey = mkPreludeTyConUnique 55
+stRetTyConKey = mkPreludeTyConUnique 56
\end{code}
%************************************************************************
trueDataConKey = mkPreludeDataConUnique 40
wordDataConKey = mkPreludeDataConUnique 41
stDataConKey = mkPreludeDataConUnique 42
+stRetDataConKey = mkPreludeDataConUnique 43
\end{code}
%************************************************************************
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 )
-> 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
-- 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)
=
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
, stateAndStablePtrPrimTyCon
, stateAndSynchVarPrimTyCon
, stateAndWordPrimTyCon
- , stateTyCon
+ , stRetTyCon
, voidTyCon
, wordTyCon
]
statePrimTyCon VoidRep [realWorldTy]
where
primio_ish_ty result
- = mkFunTy (mkStateTy realWorldTy) (mkTupleTy 2 [result, mkStateTy realWorldTy])
+ = mkFunTy (mkStatePrimTy realWorldTy) (mkSTretTy realWorldTy result)
\end{code}
%************************************************************************
stateAndWordPrimTyCon,
stateDataCon,
stateTyCon,
+ stRetDataCon,
+ stRetTyCon,
+ mkSTretTy,
stringTy,
trueDataCon,
unitTy,
\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]
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}
%************************************************************************
maybeAppDataTyConExpandingDicts, SYN_IE(Type)
)
import TyCon ( isDataTyCon )
-import TysWiredIn ( realWorldStateTy )
import TyVar ( elementOfTyVarSet,
GenTyVar{-instance Eq-} )
import Util ( isIn, panic, assertPanic )
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 )
-- 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}
"${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,
,'-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-/) {
) where
import Prelude
-import IOBase ( IO(..) ) -- Suspicious!
+import IOBase ( IO(..), ioToST, stToIO ) -- Suspicious!
import ConcBase
import STBase
import UnsafeST ( unsafeInterleavePrimIO )
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 ()
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"
{-# 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)
--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
--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}
#-}
{-# 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
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
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
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
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
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
{-# 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
#-}
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
) 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#,
\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
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)
\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}
%*********************************************************
\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:
%* *
%*********************************************************
+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)
{-# 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>>"
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:
{-# 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}
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}
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) }}
fixST k = ST $ \ s ->
let (ST k_r) = k r
ans = k_r s
- (r,new_s) = ans
+ STret _ r = ans
in
ans
%* *
%*********************************************************
+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#
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
{- 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)
{-# 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
thenST, seqST, returnST, listST, fixST, runST, unsafeInterleaveST,
mapST, mapAndUnzipST,
-- the lazy variant
- returnLazyST, thenLazyST, seqLazyST,
+ -- returnLazyST, thenLazyST, seqLazyST,
MutableVar,
newVar, readVar, writeVar, sameVar,
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#
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}
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#,'
-- 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 $
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 =
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}
-- 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"
has gotten hold of (hopefully via @MakeStablePtr#@).
*/
P_ unstable_Closure;
-ED_RO_(WorldStateToken_closure);
+ED_RO_(realWorldZh_closure);
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.
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)
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();
SpA = SuA - AREL(1);
- *SpA = (P_) WorldStateToken_closure;
+ *SpA = (P_) realWorldZh_closure;
STKO_LINK(StkOReg) = PrelBase_Z91Z93_closure;
STKO_RETURN(StkOReg) = NULL;
\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);)
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);
"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
--
--
projects / ghc-hetmet.git / commitdiff