Add two new primops:

  seq#   :: a -> State# s -> (# State# s, a #)
  spark# :: a -> State# s -> (# State# s, a #)

seq# is a version of seq that can be used in a State#-passing
context.  We will use it to implement Control.Exception.evaluate and
thus fix #5129.  Also we have plans to use it to fix #5262.

spark# is to seq# as par is to pseq.  That is, it creates a spark in a
State#-passing context.  We will use spark# and seq# to implement rpar
and rseq respectively in an improved implementation of the Eval monad.

compiler/codeGen/CgCase.lhs

@@ -157,6 +157,25 @@ cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr
     reps_compatible = idCgRep v == idCgRep bndr
 \end{code}
 
+Special case #2.5; seq#
+
+  case seq# a s of v
+    (# s', a' #) -> e
+
+  ==>
+
+  case a of v
+    (# s', a' #) -> e
+
+  (taking advantage of the fact that the return convention for (# State#, a #)
+  is the same as the return convention for just 'a')
+
+\begin{code}
+cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _)
+       live_in_whole_case live_in_alts bndr alt_type alts
+  = cgCase (StgApp a []) live_in_whole_case live_in_alts bndr alt_type alts
+\end{code}
+
 Special case #3: inline PrimOps and foreign calls.
 
 \begin{code}

compiler/codeGen/CgExpr.lhs

@@ -151,6 +151,13 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
 	tycon = tyConAppTyCon res_ty
 
 
+cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty)
+  = cgTailCall a []
+  -- seq# :: a -> State# -> (# State# , a #)
+  -- but the return convention for (# State#, a #) is exactly the same as
+  -- for just a, so we can implment seq# by
+  --   seq# a s  ==>  a
+
 cgExpr (StgOpApp (StgPrimOp primop) args res_ty)
   | primOpOutOfLine primop
 	= tailCallPrimOp primop args

compiler/codeGen/CgPrimOp.hs

@@ -126,9 +126,29 @@ emitPrimOp [res] ParOp [arg] live
 	(Just vols)
         NoC_SRT -- No SRT b/c we do PlayRisky
         CmmMayReturn
+  where
+        newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))
+
+emitPrimOp [res] SparkOp [arg] live = do
+    -- returns the value of arg in res.  We're going to therefore
+    -- refer to arg twice (once to pass to newSpark(), and once to
+    -- assign to res), so put it in a temporary.
+    tmp <- newTemp bWord
+    stmtC (CmmAssign (CmmLocal tmp) arg)
+
+    vols <- getVolatileRegs live
+    emitForeignCall' PlayRisky []
+    	(CmmCallee newspark CCallConv) 
+	[   (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint)
+          , (CmmHinted arg AddrHint)  ] 
+	(Just vols)
+        NoC_SRT -- No SRT b/c we do PlayRisky
+        CmmMayReturn
+    stmtC (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp)))
   where
 	newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))
 
+
 emitPrimOp [res] ReadMutVarOp [mutv] _
    = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord))
 

compiler/prelude/primops.txt.pp

@@ -1650,6 +1650,21 @@ primop  ParOp "par#" GenPrimOp
    has_side_effects = True
    code_size = { primOpCodeSizeForeignCall }
 
+primop SparkOp "spark#" GenPrimOp
+   a -> State# s -> (# State# s, a #)
+   with has_side_effects = True
+   code_size = { primOpCodeSizeForeignCall }
+
+primop SeqOp "seq#" GenPrimOp
+   a -> State# s -> (# State# s, a #)
+
+   -- why return the value?  So that we can control sharing of seq'd
+   -- values: in
+   --    let x = e in x `seq` ... x ...
+   -- we don't want to inline x, so better to represent it as
+   --    let x = e in case seq# x RW of (# _, x' #) -> ... x' ...
+   -- also it matches the type of rseq in the Eval monad.
+
 primop GetSparkOp "getSpark#" GenPrimOp
    State# s -> (# State# s, Int#, a #)
    with