From 693872c67bade43b2a7d30f4aa7ef815199a231b Mon Sep 17 00:00:00 2001
From: stolz <unknown>
Date: Wed, 10 Apr 2002 11:43:49 +0000
Subject: [PATCH] [project @ 2002-04-10 11:43:49 by stolz] Two new
 scheduler-API primops:

1) GHC.Conc.forkProcess/forkProcess# :: IO Int
   This is a low-level call to fork() to replace Posix.forkProcess().
   In a Concurrent Haskell setting, only the thread invoking forkProcess()
   is alive in the child process. Other threads will be GC'ed!
      This brings the RTS closer to pthreads, where a call to fork()
   doesn't clone any pthreads, either.
      The result is 0 for the child and the child's pid for the parent.
   The primop will barf() when used on mingw32, sorry.

2) GHC.Conc.labelThread/forkProcess# :: String -> IO ()
   Useful for scheduler debugging: If the RTS is compiled with DEBUGging
   support, this primitive assigns a name to the current thread which
   will be used in debugging output (+RTS -D1). For larger applications,
   simply numbering threads is not sufficient.
     Notice: The Haskell side of this call is always available, but if
   you are not compiling with debugging support, the actual primop will
   turn into a no-op.
---
 GHC/Conc.lhs |   14 +++++++++++++-
 1 file changed, 13 insertions(+), 1 deletion(-)

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 5a74f32..669be48 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: Conc.lhs,v 1.3 2001/12/21 15:07:22 simonmar Exp $
+% $Id: Conc.lhs,v 1.4 2002/04/10 11:43:49 stolz Exp $
 %
 % (c) The University of Glasgow, 1994-2000
 %
@@ -21,6 +21,8 @@ module GHC.Conc
 	, par  		-- :: a -> b -> b
 	, pseq 		-- :: a -> b -> b
 	, yield         -- :: IO ()
+	, labelThread	-- :: String -> IO ()
+	, forkProcess	-- :: IO Int
 
 	-- Waiting
 	, threadDelay	  	-- :: Int -> IO ()
@@ -47,6 +49,7 @@ import GHC.Err		( parError, seqError )
 import GHC.IOBase	( IO(..), MVar(..) )
 import GHC.Base		( Int(..) )
 import GHC.Exception    ( Exception(..), AsyncException(..) )
+import GHC.Pack		( packCString# )
 
 infixr 0 `par`, `pseq`
 \end{code}
@@ -81,6 +84,15 @@ yield :: IO ()
 yield = IO $ \s -> 
    case (yield# s) of s1 -> (# s1, () #)
 
+labelThread :: String -> IO ()
+labelThread str = IO $ \ s ->
+   let ps  = packCString# str
+       adr = byteArrayContents# ps in
+     case (labelThread# adr s) of s1 -> (# s1, () #)
+
+forkProcess :: IO Int
+forkProcess = IO $ \s -> case (forkProcess# s) of (# s1, id #) -> (# s1, (I# id) #)
+
 -- 	Nota Bene: 'pseq' used to be 'seq'
 --		   but 'seq' is now defined in PrelGHC
 --
-- 
1.7.10.4