Merge branch 'master' of http://darcs.haskell.org/ghc

3 files changed, 46 insertions, 0 deletions

diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs
index 1eea96c1b0..649bda87ef 100644
--- a/compiler/codeGen/CgCase.lhs
+++ b/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}
diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs
index 1f11495b60..fe08f50b42 100644
--- a/compiler/codeGen/CgExpr.lhs
+++ b/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
diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
index 87ed25c041..c2a57a40d2 100644
--- a/compiler/codeGen/CgPrimOp.hs
+++ b/compiler/codeGen/CgPrimOp.hs
@@ -127,8 +127,28 @@ emitPrimOp [res] ParOp [arg] live
         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))