From: sof Date: Fri, 5 Mar 1999 10:21:33 +0000 (+0000) Subject: [project @ 1999-03-05 10:21:22 by sof] X-Git-Tag: Approximately_9120_patches~6416 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=9b910bc846cfb1f1d04de2ae2915cdd4e0aef5a7;p=ghc-hetmet.git [project @ 1999-03-05 10:21:22 by sof] Support for unsafely thawing your (Byte)Arrays, i.e., added the following ops: MutableArray.unsafeThawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt) MutableArray.unsafeThawByteArray :: Ix ix => ByteArray ix -> ST s (MutableByteArray s ix) MutableArray.thawByteArray :: Ix ix => ByteArray ix -> ST s (MutableByteArray s ix) ST.unsafeThawSTArray :: Ix ix => Array ix elt -> ST s (STArray s ix elt) LazyST.unsafeThawSTArray :: Ix ix => Array ix elt -> ST s (STArray s ix elt) IOExts.unsafeFreezeIOArray :: Ix ix => IOArray ix elt -> IO (Array ix elt) IOExts.unsafeThawIOArray :: Ix ix => Array ix elt -> IO (IOArray ix elt) + removed the re-exportation of Monad that ST and LazyST did. --- diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index ee1b861..3579ca1 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -109,6 +109,8 @@ primCode [lhs] UnsafeFreezeArrayOp [rhs] primCode [lhs] UnsafeFreezeByteArrayOp [rhs] = simpleCoercion PtrRep lhs rhs +primCode [lhs] UnsafeThawByteArrayOp [rhs] + = simpleCoercion PtrRep lhs rhs \end{code} Returning the size of (mutable) byte arrays is just diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 1b978d1..c622ec2 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -152,6 +152,7 @@ data PrimOp | IndexOffForeignObjOp PrimRep | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp + | UnsafeThawArrayOp | UnsafeThawByteArrayOp | SizeofByteArrayOp | SizeofMutableByteArrayOp -- Mutable variables @@ -497,48 +498,50 @@ tagOf_PrimOp (WriteOffAddrOp Word64Rep) = ILIT(195) tagOf_PrimOp UnsafeFreezeArrayOp = ILIT(196) tagOf_PrimOp UnsafeFreezeByteArrayOp = ILIT(197) -tagOf_PrimOp SizeofByteArrayOp = ILIT(198) -tagOf_PrimOp SizeofMutableByteArrayOp = ILIT(199) - -tagOf_PrimOp NewMVarOp = ILIT(200) -tagOf_PrimOp TakeMVarOp = ILIT(201) -tagOf_PrimOp PutMVarOp = ILIT(202) -tagOf_PrimOp SameMVarOp = ILIT(203) -tagOf_PrimOp IsEmptyMVarOp = ILIT(204) -tagOf_PrimOp MakeForeignObjOp = ILIT(205) -tagOf_PrimOp WriteForeignObjOp = ILIT(206) -tagOf_PrimOp MkWeakOp = ILIT(207) -tagOf_PrimOp DeRefWeakOp = ILIT(208) -tagOf_PrimOp FinalizeWeakOp = ILIT(209) -tagOf_PrimOp MakeStableNameOp = ILIT(210) -tagOf_PrimOp EqStableNameOp = ILIT(211) -tagOf_PrimOp StableNameToIntOp = ILIT(212) -tagOf_PrimOp MakeStablePtrOp = ILIT(213) -tagOf_PrimOp DeRefStablePtrOp = ILIT(214) -tagOf_PrimOp EqStablePtrOp = ILIT(215) -tagOf_PrimOp (CCallOp _ _ _ _) = ILIT(216) -tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(217) -tagOf_PrimOp SeqOp = ILIT(218) -tagOf_PrimOp ParOp = ILIT(219) -tagOf_PrimOp ForkOp = ILIT(220) -tagOf_PrimOp KillThreadOp = ILIT(221) -tagOf_PrimOp DelayOp = ILIT(222) -tagOf_PrimOp WaitReadOp = ILIT(223) -tagOf_PrimOp WaitWriteOp = ILIT(224) -tagOf_PrimOp ParGlobalOp = ILIT(225) -tagOf_PrimOp ParLocalOp = ILIT(226) -tagOf_PrimOp ParAtOp = ILIT(227) -tagOf_PrimOp ParAtAbsOp = ILIT(228) -tagOf_PrimOp ParAtRelOp = ILIT(229) -tagOf_PrimOp ParAtForNowOp = ILIT(230) -tagOf_PrimOp CopyableOp = ILIT(231) -tagOf_PrimOp NoFollowOp = ILIT(232) -tagOf_PrimOp NewMutVarOp = ILIT(233) -tagOf_PrimOp ReadMutVarOp = ILIT(234) -tagOf_PrimOp WriteMutVarOp = ILIT(235) -tagOf_PrimOp SameMutVarOp = ILIT(236) -tagOf_PrimOp CatchOp = ILIT(237) -tagOf_PrimOp RaiseOp = ILIT(238) +tagOf_PrimOp UnsafeThawArrayOp = ILIT(198) +tagOf_PrimOp UnsafeThawByteArrayOp = ILIT(199) +tagOf_PrimOp SizeofByteArrayOp = ILIT(200) +tagOf_PrimOp SizeofMutableByteArrayOp = ILIT(201) + +tagOf_PrimOp NewMVarOp = ILIT(202) +tagOf_PrimOp TakeMVarOp = ILIT(203) +tagOf_PrimOp PutMVarOp = ILIT(204) +tagOf_PrimOp SameMVarOp = ILIT(205) +tagOf_PrimOp IsEmptyMVarOp = ILIT(206) +tagOf_PrimOp MakeForeignObjOp = ILIT(207) +tagOf_PrimOp WriteForeignObjOp = ILIT(208) +tagOf_PrimOp MkWeakOp = ILIT(209) +tagOf_PrimOp DeRefWeakOp = ILIT(210) +tagOf_PrimOp FinalizeWeakOp = ILIT(211) +tagOf_PrimOp MakeStableNameOp = ILIT(212) +tagOf_PrimOp EqStableNameOp = ILIT(213) +tagOf_PrimOp StableNameToIntOp = ILIT(214) +tagOf_PrimOp MakeStablePtrOp = ILIT(215) +tagOf_PrimOp DeRefStablePtrOp = ILIT(216) +tagOf_PrimOp EqStablePtrOp = ILIT(217) +tagOf_PrimOp (CCallOp _ _ _ _) = ILIT(218) +tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(219) +tagOf_PrimOp SeqOp = ILIT(220) +tagOf_PrimOp ParOp = ILIT(221) +tagOf_PrimOp ForkOp = ILIT(222) +tagOf_PrimOp KillThreadOp = ILIT(223) +tagOf_PrimOp DelayOp = ILIT(224) +tagOf_PrimOp WaitReadOp = ILIT(225) +tagOf_PrimOp WaitWriteOp = ILIT(226) +tagOf_PrimOp ParGlobalOp = ILIT(227) +tagOf_PrimOp ParLocalOp = ILIT(228) +tagOf_PrimOp ParAtOp = ILIT(229) +tagOf_PrimOp ParAtAbsOp = ILIT(230) +tagOf_PrimOp ParAtRelOp = ILIT(231) +tagOf_PrimOp ParAtForNowOp = ILIT(232) +tagOf_PrimOp CopyableOp = ILIT(233) +tagOf_PrimOp NoFollowOp = ILIT(234) +tagOf_PrimOp NewMutVarOp = ILIT(235) +tagOf_PrimOp ReadMutVarOp = ILIT(236) +tagOf_PrimOp WriteMutVarOp = ILIT(237) +tagOf_PrimOp SameMutVarOp = ILIT(238) +tagOf_PrimOp CatchOp = ILIT(239) +tagOf_PrimOp RaiseOp = ILIT(240) tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op) --panic# "tagOf_PrimOp: pattern-match" @@ -760,6 +763,8 @@ allThePrimOps WriteOffAddrOp Word64Rep, UnsafeFreezeArrayOp, UnsafeFreezeByteArrayOp, + UnsafeThawArrayOp, + UnsafeThawByteArrayOp, SizeofByteArrayOp, SizeofMutableByteArrayOp, NewMutVarOp, @@ -1328,6 +1333,24 @@ primOpInfo UnsafeFreezeByteArrayOp [mkMutableByteArrayPrimTy s, state] (unboxedPair [state, byteArrayPrimTy]) +primOpInfo UnsafeThawArrayOp + = let { + elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar; + state = mkStatePrimTy s + } in + mkGenPrimOp SLIT("unsafeThawArray#") [s_tv, elt_tv] + [mkArrayPrimTy elt, state] + (unboxedPair [state, mkMutableArrayPrimTy s elt]) + +primOpInfo UnsafeThawByteArrayOp + = let { + s = alphaTy; s_tv = alphaTyVar; + state = mkStatePrimTy s + } in + mkGenPrimOp SLIT("unsafeThawByteArray#") [s_tv] + [byteArrayPrimTy, state] + (unboxedPair [state, mkMutableByteArrayPrimTy s]) + --------------------------------------------------------------------------- primOpInfo SizeofByteArrayOp = mkGenPrimOp @@ -1838,6 +1861,11 @@ primOpOutOfLine op ForkOp -> True KillThreadOp -> True CCallOp _ _ may_gc@True _ -> True -- _ccall_GC_ + -- the next one doesn't perform any heap checks, + -- but it is of such an esoteric nature that + -- it is done out-of-line rather than require + -- the NCG to implement it. + UnsafeThawArrayOp -> True _ -> False \end{code} diff --git a/ghc/docs/users_guide/MutableArray.sgml b/ghc/docs/users_guide/MutableArray.sgml index 4b08458..b22920f 100644 --- a/ghc/docs/users_guide/MutableArray.sgml +++ b/ghc/docs/users_guide/MutableArray.sgml @@ -25,7 +25,8 @@ writeArray :: Ix ix => MutableArray s ix elt -> ix -> elt -> ST s () freezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) thawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt) -unsafeFreezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) +unsafeFreezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) +unsafeThawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt) newArray boundsOfArray @@ -34,6 +35,7 @@ unsafeFreezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) freezeArray thawArray unsafeFreezeArray +unsafeThawArray The operation MutableByteArray s ix -> ST s (ByteArray ix) sizeofMutableByteArray :: Ix ix => MutableByteArray s ix -> Int +thawByteArray :: Ix ix => ByteArray ixt -> ST s (MutableByteArray s ix) +unsafeThawByteArray :: Ix ix => ByteArray ixt -> ST s (MutableByteArray s ix) + newCharArray newAddrArray @@ -150,6 +156,8 @@ sizeofMutableByteArray :: Ix ix => MutableByteArray s ix -> Int freezeFloatArray freezeDoubleArray unsafeFreezeByteArray +unsafeThawByteArray +thawByteArray @@ -192,7 +200,10 @@ into immutable byte arrays are also provided by the -Thawing of byte arrays is currently not supported. + +Operations for going the other way, where an immutable byte +array is 'thawed' are also provided. The operation words * sizeof(W_)) diff --git a/ghc/lib/exts/IOExts.lhs b/ghc/lib/exts/IOExts.lhs index 612b37d..1b65497 100644 --- a/ghc/lib/exts/IOExts.lhs +++ b/ghc/lib/exts/IOExts.lhs @@ -30,6 +30,10 @@ module IOExts , writeIOArray , freezeIOArray , thawIOArray +#ifndef __HUGS__ + , unsafeFreezeIOArray + , unsafeThawIOArray +#endif #ifdef __HUGS__ #else @@ -111,6 +115,10 @@ readIOArray :: Ix ix => IOArray ix elt -> ix -> IO elt writeIOArray :: Ix ix => IOArray ix elt -> ix -> elt -> IO () freezeIOArray :: Ix ix => IOArray ix elt -> IO (Array ix elt) thawIOArray :: Ix ix => Array ix elt -> IO (IOArray ix elt) +#ifndef __HUGS__ +unsafeFreezeIOArray :: Ix ix => IOArray ix elt -> IO (Array ix elt) +unsafeThawIOArray :: Ix ix => Array ix elt -> IO (IOArray ix elt) +#endif #ifdef __HUGS__ type IOArray ix elt = STArray RealWorld ix elt @@ -139,6 +147,11 @@ freezeIOArray (IOArray arr) = stToIO (freezeArray arr) thawIOArray arr = do marr <- stToIO (thawArray arr) return (IOArray marr) + +unsafeFreezeIOArray (IOArray arr) = stToIO (unsafeFreezeArray arr) +unsafeThawIOArray arr = do + marr <- stToIO (unsafeThawArray arr) + return (IOArray marr) #endif \end{code} diff --git a/ghc/lib/exts/LazyST.lhs b/ghc/lib/exts/LazyST.lhs index 767bb29..9b9baab 100644 --- a/ghc/lib/exts/LazyST.lhs +++ b/ghc/lib/exts/LazyST.lhs @@ -15,16 +15,13 @@ module LazyST ( runST, unsafeInterleaveST, - -- ST is one, so you'll likely need some Monad bits - module Monad, - ST.STRef, newSTRef, readSTRef, writeSTRef, STArray, newSTArray, readSTArray, writeSTArray, boundsSTArray, thawSTArray, freezeSTArray, unsafeFreezeSTArray, - Ix, + unsafeThawSTArray, ST.unsafeIOToST, ST.stToIO, @@ -117,6 +114,9 @@ thawSTArray arr = freezeSTArray (STArray arr) = strictToLazyST (freezeArray arr) unsafeFreezeSTArray (STArray arr) = strictToLazyST (unsafeFreezeArray arr) +unsafeThawSTArray arr = + strictToLazyST (unsafeThawArray arr) >>= \ marr -> + return (STArray marr) strictToLazyST :: PrelST.ST s a -> ST s a strictToLazyST m = ST $ \s -> diff --git a/ghc/lib/exts/MutableArray.lhs b/ghc/lib/exts/MutableArray.lhs index d5adb92..288974d 100644 --- a/ghc/lib/exts/MutableArray.lhs +++ b/ghc/lib/exts/MutableArray.lhs @@ -55,7 +55,11 @@ module MutableArray unsafeFreezeArray, -- :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) unsafeFreezeByteArray, -- :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) - thawArray, -- :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt) + + thawArray, -- :: Ix ix => Array ix elt -> ST s (MutableArray s ix) + thawByteArray, -- :: Ix ix => ByteArray ix -> ST s (MutableByteArray s ix) + unsafeThawArray, -- :: Ix ix => Array ix elt -> ST s (MutableArray s ix) + unsafeThawByteArray, -- :: Ix ix => ByteArray ix -> ST s (MutableByteArray s ix) -- the sizes are reported back are *in bytes*. sizeofMutableByteArray, -- :: Ix ix => MutableByteArray s ix -> Int @@ -378,3 +382,33 @@ boundsOfMutableByteArray :: Ix ix => MutableByteArray s ix -> (ix, ix) boundsOfMutableByteArray (MutableByteArray ixs _) = ixs \end{code} + +\begin{code} +thawByteArray :: Ix ix => ByteArray ix -> ST s (MutableByteArray s ix) +thawByteArray (ByteArray ixs barr#) = + {- + The implementation is made more complex by the + fact that the indexes are in units of whatever + base types that's stored in the byte array. + -} + case (sizeofByteArray# barr#) of + i# -> do + marr <- newCharArray (0,I# i#) + mapM_ (\ idx@(I# idx#) -> + writeCharArray marr idx (C# (indexCharArray# barr# idx#))) + [0..] + let (MutableByteArray _ arr#) = marr + return (MutableByteArray ixs arr#) + +{- + in-place conversion of immutable arrays to mutable ones places + a proof obligation on the user: no other parts of your code can + have a reference to the array at the point where you unsafely + thaw it (and, subsequently mutate it, I suspect.) +-} +unsafeThawByteArray :: Ix ix => ByteArray ix -> ST s (MutableByteArray s ix) +unsafeThawByteArray (ByteArray ixs barr#) = ST $ \ s# -> + case unsafeThawByteArray# barr# s# of + (# s2#, arr# #) -> (# s2#, MutableByteArray ixs arr# #) + +\end{code} diff --git a/ghc/lib/exts/ST.lhs b/ghc/lib/exts/ST.lhs index e7d6fc8..c946a17 100644 --- a/ghc/lib/exts/ST.lhs +++ b/ghc/lib/exts/ST.lhs @@ -6,29 +6,35 @@ \begin{code} {-# OPTIONS -fno-implicit-prelude #-} -module ST ( - - ST, - - runST, -- :: (forall s. ST s a) -> a - fixST, -- :: (a -> ST s a) -> ST s a - - unsafeInterleaveST, - - -- ST is one, so you'll likely need some Monad bits - module Monad, - - STRef, - newSTRef, readSTRef, writeSTRef, - - unsafeIOToST, stToIO, - - STArray, - newSTArray, readSTArray, writeSTArray, boundsSTArray, - thawSTArray, freezeSTArray, unsafeFreezeSTArray, - Ix +module ST + ( + ST -- abstract, instance of Functor, Monad. + , runST -- :: (forall s. ST s a) -> a + , fixST -- :: (a -> ST s a) -> ST s a + , unsafeInterleaveST -- :: ST s a -> ST s a + + , STRef + , newSTRef + , readSTRef + , writeSTRef + + , unsafeIOToST + , stToIO + + , STArray + , newSTArray + , readSTArray + , writeSTArray + , boundsSTArray + , thawSTArray + , freezeSTArray + , unsafeFreezeSTArray +#ifndef __HUGS__ +-- no 'good' reason, just doesn't support it right now. + , unsafeThawSTArray +#endif - ) where + ) where #ifdef __HUGS__ import PreludeBuiltin @@ -82,6 +88,11 @@ thawSTArray :: Ix ix => Array ix elt -> ST s (STArray s ix elt) freezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt) unsafeFreezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt) +#ifndef __HUGS__ +-- see export list comment.. +unsafeThawSTArray :: Ix ix => Array ix elt -> ST s (STArray s ix elt) +#endif + #ifdef __HUGS__ data STArray s ix elt = STArray (ix,ix) (PrimMutableArray s elt) deriving Eq @@ -149,6 +160,8 @@ thawSTArray arr = thawArray arr >>= \starr -> return (STArray starr) freezeSTArray (STArray arr) = freezeArray arr unsafeFreezeSTArray (STArray arr) = unsafeFreezeArray arr +unsafeThawSTArray arr = unsafeThawArray arr >>= \ marr -> return (STArray marr) + #endif \end{code} diff --git a/ghc/lib/std/PrelArr.lhs b/ghc/lib/std/PrelArr.lhs index 331bc26..5f93a93 100644 --- a/ghc/lib/std/PrelArr.lhs +++ b/ghc/lib/std/PrelArr.lhs @@ -637,4 +637,12 @@ thawArray (Array ixs arr#) = ST $ \ s# -> case writeArray# to# cur# ele st# of { s1# -> copy (cur# +# 1#) end# from# to# s1# }} + +-- this is a quicker version of the above, just flipping the type +-- (& representation) of an immutable array. And placing a +-- proof obligation on the programmer. +unsafeThawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt) +unsafeThawArray (Array ixs arr#) = ST $ \ s# -> + case unsafeThawArray# arr# s# of + (# s2#, marr# #) -> (# s2#, MutableArray ixs marr# #) \end{code} diff --git a/ghc/lib/std/PrelGHC.hi-boot b/ghc/lib/std/PrelGHC.hi-boot index 49520a9..5f9e2c9 100644 --- a/ghc/lib/std/PrelGHC.hi-boot +++ b/ghc/lib/std/PrelGHC.hi-boot @@ -277,6 +277,9 @@ __export PrelGHC unsafeFreezzeArrayzh -- Note zz in the middle unsafeFreezzeByteArrayzh -- Ditto + unsafeThawArrayzh + unsafeThawByteArrayzh + sizzeofByteArrayzh -- Ditto sizzeofMutableByteArrayzh -- Ditto diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc index e2e1010..5c911ba 100644 --- a/ghc/rts/PrimOps.hc +++ b/ghc/rts/PrimOps.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.hc,v 1.20 1999/03/03 19:11:43 sof Exp $ + * $Id: PrimOps.hc,v 1.21 1999/03/05 10:21:27 sof Exp $ * * (c) The GHC Team, 1998-1999 * @@ -297,6 +297,18 @@ FN_(makeForeignObjzh_fast) } #endif +/* These two are out-of-line for the benefit of the NCG */ +FN_(unsafeThawArrayzh_fast) +{ + FB_ + SET_INFO((StgClosure *)R1.cl,&MUT_ARR_PTRS_info); + recordMutable((StgMutClosure*)R1.cl); + + TICK_RET_UNBOXED_TUP(1); + RET_P(R1.p); + FE_ +} + /* ----------------------------------------------------------------------------- Weak Pointer Primitives -------------------------------------------------------------------------- */