X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2Fprimops.txt.pp;h=e699bb56ce8fc7f3183147e13dbadb75f8ba0463;hb=24f3d678e8ce4f075023efb4be0d59efe000e446;hp=2a58a75e885f08d545d109ed1450c55f58699ecc;hpb=c1f3fad183f553aa46ec9dea33999f387014fded;p=ghc-hetmet.git

diff --git a/ghc/compiler/prelude/primops.txt.pp b/ghc/compiler/prelude/primops.txt.pp
index 2a58a75..e699bb5 100644
--- a/ghc/compiler/prelude/primops.txt.pp
+++ b/ghc/compiler/prelude/primops.txt.pp
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------
--- $Id: primops.txt.pp,v 1.18 2002/04/10 11:43:43 stolz Exp $
+-- $Id: primops.txt.pp,v 1.32 2005/01/31 13:25:38 simonpj Exp $
 --
 -- Primitive Operations
 --
@@ -1274,6 +1274,18 @@ primop  SameMutVarOp "sameMutVar#" GenPrimOp
    with
    usage = { mangle SameMutVarOp [mkP, mkP] mkM }
 
+-- not really the right type, but we don't know about pairs here.  The
+-- correct type is
+--
+--   MutVar# s a -> (a -> (a,b)) -> State# s -> (# State# s, b #)
+--
+primop  AtomicModifyMutVarOp "atomicModifyMutVar#" GenPrimOp
+   MutVar# s a -> (a -> b) -> State# s -> (# State# s, c #)
+   with
+   usage = { mangle AtomicModifyMutVarOp [mkP, mkM, mkP] mkM }
+   has_side_effects = True
+   out_of_line = True
+
 ------------------------------------------------------------------------
 section "Exceptions"
 ------------------------------------------------------------------------
@@ -1300,6 +1312,15 @@ primop  RaiseOp "raise#" GenPrimOp
    usage       = { mangle RaiseOp [mkM] mkM }
    out_of_line = True
 
+-- raiseIO# needs to be a primop, because exceptions in the IO monad
+-- must be *precise* - we don't want the strictness analyser turning
+-- one kind of bottom into another, as it is allowed to do in pure code.
+
+primop  RaiseIOOp "raiseIO#" GenPrimOp
+   a -> State# RealWorld -> (# State# RealWorld, b #)
+   with
+   out_of_line = True
+
 primop  BlockAsyncExceptionsOp "blockAsyncExceptions#" GenPrimOp
         (State# RealWorld -> (# State# RealWorld, a #))
      -> (State# RealWorld -> (# State# RealWorld, a #))
@@ -1313,6 +1334,66 @@ primop  UnblockAsyncExceptionsOp "unblockAsyncExceptions#" GenPrimOp
    out_of_line = True
 
 ------------------------------------------------------------------------
+section "STM-accessible Mutable Variables"
+------------------------------------------------------------------------
+
+primop	AtomicallyOp "atomically#" GenPrimOp
+      (State# RealWorld -> (# State# RealWorld, a #) )
+   -> State# RealWorld -> (# State# RealWorld, a #)
+   with
+   out_of_line = True
+   has_side_effects = True
+
+primop  RetryOp "retry#" GenPrimOp
+   State# RealWorld -> (# State# RealWorld, a #)
+   with 
+   out_of_line = True
+   has_side_effects = True
+
+primop  CatchRetryOp "catchRetry#" GenPrimOp
+      (State# RealWorld -> (# State# RealWorld, a #) )
+   -> (State# RealWorld -> (# State# RealWorld, a #) )
+   -> (State# RealWorld -> (# State# RealWorld, a #) )
+   with 
+   out_of_line = True
+   has_side_effects = True
+
+primop  CatchSTMOp "catchSTM#" GenPrimOp
+      (State# RealWorld -> (# State# RealWorld, a #) )
+   -> (b -> State# RealWorld -> (# State# RealWorld, a #) )
+   -> (State# RealWorld -> (# State# RealWorld, a #) )
+   with 
+   out_of_line = True
+   has_side_effects = True
+
+primop	NewTVarOp "newTVar#" GenPrimOp
+       a
+    -> State# s -> (# State# s, TVar# s a #)
+   {Create a new Tar\# holding a specified initial value.}
+   with
+   out_of_line  = True
+
+primop	ReadTVarOp "readTVar#" GenPrimOp
+       TVar# s a
+    -> State# s -> (# State# s, a #)
+   {Read contents of TVar\#.  Result is not yet evaluated.}
+   with
+   out_of_line	= True
+
+primop	WriteTVarOp "writeTVar#" GenPrimOp
+       TVar# s a
+    -> a
+    -> State# s -> State# s
+   {Write contents of TVar\#.}
+   with
+   out_of_line	    = True
+   has_side_effects = True
+
+primop  SameTVarOp "sameTVar#" GenPrimOp
+   TVar# s a -> TVar# s a -> Bool
+
+
+------------------------------------------------------------------------
 section "Synchronized Mutable Variables"
 	{Operations on MVar\#s, which are shared mutable variables
 	({\it not} the same as MutVar\#s!). (Note: in a non-concurrent implementation,
@@ -1403,6 +1484,33 @@ primop  WaitWriteOp "waitWrite#" GenPrimOp
    has_side_effects = True
    out_of_line      = True
 
+#ifdef mingw32_TARGET_OS
+primop  AsyncReadOp "asyncRead#" GenPrimOp
+   Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #)
+   {Asynchronously read bytes from specified file descriptor.}
+   with
+   needs_wrapper    = True
+   has_side_effects = True
+   out_of_line      = True
+
+primop  AsyncWriteOp "asyncWrite#" GenPrimOp
+   Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #)
+   {Asynchronously write bytes from specified file descriptor.}
+   with
+   needs_wrapper    = True
+   has_side_effects = True
+   out_of_line      = True
+
+primop  AsyncDoProcOp "asyncDoProc#" GenPrimOp
+   Addr# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #)
+   {Asynchronously perform procedure (first arg), passing it 2nd arg.}
+   with
+   needs_wrapper    = True
+   has_side_effects = True
+   out_of_line      = True
+
+#endif
+
 ------------------------------------------------------------------------
 section "Concurrency primitives"
 	{(In a non-concurrent implementation, ThreadId\# can be as singleton
@@ -1417,12 +1525,6 @@ primop  ForkOp "fork#" GenPrimOp
    has_side_effects = True
    out_of_line      = True
 
-primop ForkProcessOp "forkProcess#" GenPrimOp
-   State# RealWorld -> (# State# RealWorld, Int#  #)
-   with
-   has_side_effects = True
-   out_of_line      = True
-
 primop  KillThreadOp "killThread#"  GenPrimOp
    ThreadId# -> a -> State# RealWorld -> State# RealWorld
    with
@@ -1442,10 +1544,15 @@ primop  MyThreadIdOp "myThreadId#" GenPrimOp
    out_of_line = True
 
 primop LabelThreadOp "labelThread#" GenPrimOp
-   Addr# -> State# RealWorld -> State# RealWorld
+   ThreadId# -> Addr# -> State# RealWorld -> State# RealWorld
    with
    has_side_effects = True
    out_of_line      = True
+   
+primop  IsCurrentThreadBoundOp "isCurrentThreadBound#" GenPrimOp
+   State# RealWorld -> (# State# RealWorld, Int# #)
+   with
+   out_of_line = True
 
 ------------------------------------------------------------------------
 section "Weak pointers"
@@ -1469,7 +1576,7 @@ primop  DeRefWeakOp "deRefWeak#" GenPrimOp
 
 primop  FinalizeWeakOp "finalizeWeak#" GenPrimOp
    Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, 
-              (State# RealWorld -> (# State# RealWorld, Unit #)) #)
+              (State# RealWorld -> (# State# RealWorld, () #)) #)
    with
    usage            = { mangle FinalizeWeakOp [mkM, mkP] 
                                (mkR . (inUB FinalizeWeakOp 
@@ -1521,16 +1628,18 @@ primop  StableNameToIntOp "stableNameToInt#" GenPrimOp
    usage = { mangle StableNameToIntOp [mkP] mkR }
 
 ------------------------------------------------------------------------
-section "Parallelism"
+section "Unsafe pointer equality"
+--  (#1 Bad Guy: Alistair Reid :)   
 ------------------------------------------------------------------------
 
-primop  SeqOp "seq#" GenPrimOp
-   a -> Int#
+primop  ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
+   a -> a -> Int#
    with
-   usage            = { mangle  SeqOp [mkO] mkR }
-   strictness       = { \ arity -> mkStrictSig (mkTopDmdType [evalDmd] TopRes) }
-      -- Seq is strict in its argument; see notes in ConFold.lhs
-   has_side_effects = True
+   usage = { mangle ReallyUnsafePtrEqualityOp [mkZ, mkZ] mkR }
+
+------------------------------------------------------------------------
+section "Parallelism"
+------------------------------------------------------------------------
 
 primop  ParOp "par#" GenPrimOp
    a -> Int#
@@ -1605,6 +1714,9 @@ section "Tag to enum stuff"
 
 primop  DataToTagOp "dataToTag#" GenPrimOp
    a -> Int#
+   with
+   strictness  = { \ arity -> mkStrictSig (mkTopDmdType [seqDmd] TopRes) }
+	-- dataToTag# must have an evaluated argument
 
 primop  TagToEnumOp "tagToEnum#" GenPrimOp     
    Int# -> a
@@ -1620,12 +1732,12 @@ primop   AddrToHValueOp "addrToHValue#" GenPrimOp
    {Convert an Addr\# to a followable type.}
 
 primop   MkApUpd0_Op "mkApUpd0#" GenPrimOp
-   a -> (# a #)
+   BCO# -> (# a #)
    with
    out_of_line = True
 
 primop  NewBCOOp "newBCO#" GenPrimOp
-   ByteArr# -> ByteArr# -> Array# a -> ByteArr# -> State# s -> (# State# s, BCO# #)
+   ByteArr# -> ByteArr# -> Array# a -> ByteArr# -> Int# -> ByteArr# -> State# s -> (# State# s, BCO# #)
    with
    has_side_effects = True
    out_of_line      = True