[commit: ghc] ghc-7.2: Port 'Add two new primops seq# and spark#' (be54417) to new codegen. (5d757e5)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-7.2

http://hackage.haskell.org/trac/ghc/changeset/5d757e5c07460dc8729cdc6c316318b09ac97947

>---------------------------------------------------------------

commit 5d757e5c07460dc8729cdc6c316318b09ac97947
Author: Edward Z. Yang <ezyang at mit.edu>
Date:   Thu Jul 7 20:48:48 2011 -0400

    Port 'Add two new primops seq# and spark#' (be54417) to new codegen.
    
    Signed-off-by: Edward Z. Yang <ezyang at mit.edu>

>---------------------------------------------------------------

 compiler/codeGen/StgCmmExpr.hs |   20 ++++++++++++++++++++
 compiler/codeGen/StgCmmPrim.hs |   12 ++++++++++++
 2 files changed, 32 insertions(+), 0 deletions(-)

diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index eee4a08..0edcbe4 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -71,6 +71,10 @@ cgExpr (StgLetNoEscape _ _ binds expr) =
 cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) =
   cgCase expr bndr srt alt_type alts
 
+{- seq# a s ==> a -}
+cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
+  cgIdApp a []
+
 cgExpr (StgLam {}) = panic "cgExpr: StgLam"
 
 ------------------------------------------------------------------------
@@ -322,6 +326,22 @@ cgCase scrut@(StgApp v []) _ _ (PrimAlt _) _
        ; emit $ mkComment $ mkFastString "should be unreachable code"
        ; emit $ withFreshLabel "l" (\l -> mkLabel l <*> mkBranch l)}
 
+{-
+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')
+-}
+cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr srt alt_type alts
+  = -- handle seq#, same return convention as vanilla 'a'.
+    cgCase (StgApp a []) bndr srt alt_type alts
+
 cgCase scrut bndr srt alt_type alts 
   = -- the general case
     do { up_hp_usg <- getVirtHp        -- Upstream heap usage
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 1a6d05e..c71d285 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -210,6 +210,18 @@ emitPrimOp [res] ParOp [arg]
     	(CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))))
 	[(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] 
 
+emitPrimOp [res] SparkOp [arg]
+  = 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 <- assignTemp arg
+        emitCCall
+            []
+            (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))))
+            [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
+        emit (mkAssign (CmmLocal res) (CmmReg (CmmLocal tmp)))
+
 emitPrimOp [res] ReadMutVarOp [mutv]
    = emit (mkAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord))