I was puzzled why, post this commit, things werent' compiling. That's cuz we haven't ported this to the new codegen yet. I'll do this some time this week.
Edward Excerpts from Simon Marlow's message of Tue Jun 28 16:30:43 -0400 2011: > 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 > _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
