Commit df10403c authored by simonm's avatar simonm
Browse files

[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.
parent 25a3b273
......@@ -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}
%************************************************************************
......
......@@ -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
......
......@@ -169,7 +169,7 @@ data_tycons
, stateAndStablePtrPrimTyCon
, stateAndSynchVarPrimTyCon
, stateAndWordPrimTyCon
, stateTyCon
, stRetTyCon
, voidTyCon
, wordTyCon
]
......
......@@ -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}
%************************************************************************
......
......@@ -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}
%************************************************************************
......
......@@ -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 )
......
......@@ -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}
......
......@@ -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,
......
......@@ -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-/) {
......
......@@ -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 ()
......
......@@ -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
......
......@@ -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}
%*********************************************************
......
......@@ -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:
......
......@@ -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}