Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-7.2
http://hackage.haskell.org/trac/ghc/changeset/d7aed5e6aa9d308bf93dbebd7f940a2f81a65279 >--------------------------------------------------------------- commit d7aed5e6aa9d308bf93dbebd7f940a2f81a65279 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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
