Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : master
http://hackage.haskell.org/trac/ghc/changeset/be5441799b7d94646dcd4bfea15407883537eaaa
---------------------------------------------------------------
commit be5441799b7d94646dcd4bfea15407883537eaaa
Author: Simon Marlow<[email protected]>
Date: Mon Jun 27 16:45:15 2011 +0100
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 | 19 +++++++++++++++++++
compiler/codeGen/CgExpr.lhs | 7 +++++++
compiler/codeGen/CgPrimOp.hs | 20 ++++++++++++++++++++
compiler/prelude/primops.txt.pp | 15 +++++++++++++++
4 files changed, 61 insertions(+), 0 deletions(-)
diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs
index 1eea96c..649bda8 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 1f11495..fe08f50 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 87ed25c..c2a57a4 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))
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index ce2462c..4949846 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/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
