Pushed. Excerpts from Simon Marlow's message of Tue Jul 05 08:37:30 -0400 2011: > On 05/07/11 13:19, Edward Z. Yang wrote: > > 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. > > Oh, my apologies - I intended to get to this, then it slipped my mind. > If you could do it that would be great (should be fairly straightforward). > > Cheers, > Simon > > > 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
