winio: Add IOPort synchronization primitive

4 files changed, 69 insertions, 7 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 02a10d4b35..b9ef184923 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -1747,7 +1747,7 @@ addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey,
     weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey,
     mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey,
     ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey,
-    stablePtrTyConKey, eqTyConKey, heqTyConKey,
+    stablePtrTyConKey, eqTyConKey, heqTyConKey, ioPortPrimTyConKey,
     smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey,
     stringTyConKey :: Unique
 addrPrimTyConKey                        = mkPreludeTyConUnique  1
@@ -1783,11 +1783,12 @@ mutableArrayPrimTyConKey                = mkPreludeTyConUnique 30
 mutableByteArrayPrimTyConKey            = mkPreludeTyConUnique 31
 orderingTyConKey                        = mkPreludeTyConUnique 32
 mVarPrimTyConKey                        = mkPreludeTyConUnique 33
-ratioTyConKey                           = mkPreludeTyConUnique 34
-rationalTyConKey                        = mkPreludeTyConUnique 35
-realWorldTyConKey                       = mkPreludeTyConUnique 36
-stablePtrPrimTyConKey                   = mkPreludeTyConUnique 37
-stablePtrTyConKey                       = mkPreludeTyConUnique 38
+ioPortPrimTyConKey                      = mkPreludeTyConUnique 34
+ratioTyConKey                           = mkPreludeTyConUnique 35
+rationalTyConKey                        = mkPreludeTyConUnique 36
+realWorldTyConKey                       = mkPreludeTyConUnique 37
+stablePtrPrimTyConKey                   = mkPreludeTyConUnique 38
+stablePtrTyConKey                       = mkPreludeTyConUnique 39
 eqTyConKey                              = mkPreludeTyConUnique 40
 heqTyConKey                             = mkPreludeTyConUnique 41
 arrayArrayPrimTyConKey                  = mkPreludeTyConUnique 42
diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs
index 88ef943a64..13f08739d0 100644
--- a/compiler/GHC/Builtin/Types/Prim.hs
+++ b/compiler/GHC/Builtin/Types/Prim.hs
@@ -62,6 +62,7 @@ module GHC.Builtin.Types.Prim(
         mutVarPrimTyCon, mkMutVarPrimTy,
 
         mVarPrimTyCon,                  mkMVarPrimTy,
+        ioPortPrimTyCon,                mkIOPortPrimTy,
         tVarPrimTyCon,                  mkTVarPrimTy,
         stablePtrPrimTyCon,             mkStablePtrPrimTy,
         stableNamePrimTyCon,            mkStableNamePrimTy,
@@ -171,6 +172,7 @@ exposedPrimTyCons
     , mutableArrayArrayPrimTyCon
     , smallMutableArrayPrimTyCon
     , mVarPrimTyCon
+    , ioPortPrimTyCon
     , tVarPrimTyCon
     , mutVarPrimTyCon
     , realWorldTyCon
@@ -207,7 +209,7 @@ mkBuiltInPrimTc fs unique tycon
                   BuiltInSyntax
 
 
-charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name
 charPrimTyConName             = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
 intPrimTyConName              = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon
 int8PrimTyConName             = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon
@@ -238,6 +240,7 @@ mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByte
 mutableArrayArrayPrimTyConName= mkPrimTc (fsLit "MutableArrayArray#") mutableArrayArrayPrimTyConKey mutableArrayArrayPrimTyCon
 smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon
 mutVarPrimTyConName           = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon
+ioPortPrimTyConName           = mkPrimTc (fsLit "IOPort#") ioPortPrimTyConKey ioPortPrimTyCon
 mVarPrimTyConName             = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon
 tVarPrimTyConName             = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon
 stablePtrPrimTyConName        = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon
@@ -1006,7 +1009,22 @@ mkMutVarPrimTy s elt        = TyConApp mutVarPrimTyCon [s, elt]
 {-
 ************************************************************************
 *                                                                      *
+\subsection[TysPrim-io-port-var]{The synchronizing I/O Port type}
+*                                                                      *
+************************************************************************
+-}
+
+ioPortPrimTyCon :: TyCon
+ioPortPrimTyCon = pcPrimTyCon ioPortPrimTyConName [Nominal, Representational] UnliftedRep
+
+mkIOPortPrimTy :: Type -> Type -> Type
+mkIOPortPrimTy s elt          = TyConApp ioPortPrimTyCon [s, elt]
+
+{-
+************************************************************************
+*                                                                      *
    The synchronizing variable type
+\subsection[TysPrim-synch-var]{The synchronizing variable type}
 *                                                                      *
 ************************************************************************
 -}
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index a12ac1f29c..261d02aa67 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -2827,6 +2827,45 @@ primop  IsEmptyMVarOp "isEmptyMVar#" GenPrimOp
    out_of_line = True
    has_side_effects = True
 
+
+------------------------------------------------------------------------
+section "Synchronized I/O Ports"
+        {Operations on {\tt IOPort\#}s. }
+------------------------------------------------------------------------
+
+primtype IOPort# s a
+        { A shared I/O port is almost the same as a {\tt MVar\#}!).
+        The main difference is that IOPort has no deadlock detection or
+        deadlock breaking code that forcibly releases the lock. }
+
+primop  NewIOPortrOp "newIOPort#"  GenPrimOp
+   State# s -> (# State# s, IOPort# s a #)
+   {Create new {\tt IOPort\#}; initially empty.}
+   with
+   out_of_line = True
+   has_side_effects = True
+
+primop  ReadIOPortOp "readIOPort#" GenPrimOp
+   IOPort# s a -> State# s -> (# State# s, a #)
+   {If {\tt IOPort\#} is empty, block until it becomes full.
+   Then remove and return its contents, and set it empty.}
+   with
+   out_of_line      = True
+   has_side_effects = True
+
+primop  WriteIOPortOp "writeIOPort#" GenPrimOp
+   IOPort# s a -> a -> State# s -> (# State# s, Int# #)
+   {If {\tt IOPort\#} is full, immediately return with integer 0.
+    Otherwise, store value arg as {\tt IOPort\#}'s new contents,
+    and return with integer 1. }
+   with
+   out_of_line      = True
+   has_side_effects = True
+
+primop  SameIOPortOp "sameIOPort#" GenPrimOp
+   IOPort# s a -> IOPort# s a -> Int#
+
+
 ------------------------------------------------------------------------
 section "Delay/wait operations"
 ------------------------------------------------------------------------
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index ef5e376be8..afbcc34836 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -1320,6 +1320,7 @@ emitPrimOp dflags primop = case primop of
 
   SameMutVarOp            -> \args -> opTranslate args (mo_wordEq platform)
   SameMVarOp              -> \args -> opTranslate args (mo_wordEq platform)
+  SameIOPortOp            -> \args -> opTranslate args (mo_wordEq platform)
   SameMutableArrayOp      -> \args -> opTranslate args (mo_wordEq platform)
   SameMutableByteArrayOp  -> \args -> opTranslate args (mo_wordEq platform)
   SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq platform)
@@ -1467,6 +1468,9 @@ emitPrimOp dflags primop = case primop of
   ReadMVarOp -> alwaysExternal
   TryReadMVarOp -> alwaysExternal
   IsEmptyMVarOp -> alwaysExternal
+  NewIOPortrOp -> alwaysExternal
+  ReadIOPortOp -> alwaysExternal
+  WriteIOPortOp -> alwaysExternal
   DelayOp -> alwaysExternal
   WaitReadOp -> alwaysExternal
   WaitWriteOp -> alwaysExternal