Commit 80e39963 authored by simonpj's avatar simonpj
Browse files

[project @ 2002-06-18 13:58:22 by simonpj]

---------------------------------------
	    Rehash the handling of SeqOp
	---------------------------------------

See the comments in the commentary (Cunning Prelude Code).

* Expunge SeqOp altogether

* Add GHC.Base.lazy :: a -> a
  to GHC.Base

* Add GHC.Base.lazy
  to basicTypes/MkId.  The idea is that this defn will over-ride
  the info from GHC.Base.hi, thereby hiding strictness and
  unfolding

* Make stranal/WorkWrap do a "manual inlining" for GHC.Base.lazy
  This happens nicely after the strictness analyser has run.

* Expunge the SeqOp/ParOp magic in CorePrep

* Expunge the RULE for seq in PrelRules

* Change the defns of pseq/par in GHC.Conc to:

	{-# INLINE pseq  #-}
       	pseq :: a -> b -> b
       	pseq  x y = x `seq` lazy y

       	{-# INLINE par  #-}
       	par :: a -> b -> b
       	par  x y = case (par# x) of { _ -> lazy y }
parent 8c4c38a1
......@@ -25,6 +25,7 @@ module MkId (
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
lazyId, lazyIdUnfolding, lazyIdKey,
mkRuntimeErrorApp,
rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
......@@ -128,7 +129,9 @@ wiredInIds
nON_EXHAUSTIVE_GUARDS_ERROR_ID,
nO_METHOD_BINDING_ERROR_ID,
pAT_ERROR_ID,
rEC_CON_ERROR_ID
rEC_CON_ERROR_ID,
lazyId
] ++ ghcPrimIds
-- These Ids are exported from GHC.Prim
......@@ -838,6 +841,23 @@ seqId
(mkFunTy alphaTy (mkFunTy betaTy betaTy))
[x,y] = mkTemplateLocals [alphaTy, betaTy]
rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x [(DEFAULT, [], Var y)])
-- lazy :: forall a?. a? -> a? (i.e. works for unboxed types too)
-- Used to lazify pseq: pseq a b = a `seq` lazy b
-- No unfolding: it gets "inlined" by the worker/wrapper pass
-- Also, no strictness: by being a built-in Id, it overrides all
-- the info in PrelBase.hi. This is important, because the strictness
-- analyser will spot it as strict!
lazyId
= pcMiscPrelId lazyIdKey pREL_BASE FSLIT("lazy") ty info
where
info = noCafIdInfo
ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
lazyIdUnfolding :: CoreExpr -- Used to expand LazyOp after strictness anal
lazyIdUnfolding = mkLams [openAlphaTyVar,x] (Var x)
where
[x] = mkTemplateLocals [openAlphaTy]
\end{code}
@getTag#@ is another function which can't be defined in Haskell. It needs to
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgExpr.lhs,v 1.48 2002/04/29 14:03:41 simonmar Exp $
% $Id: CgExpr.lhs,v 1.49 2002/06/18 13:58:23 simonpj Exp $
%
%********************************************************
%* *
......@@ -150,9 +150,7 @@ cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
= tailCallPrimOp primop args
| otherwise
= ASSERT(primop /= SeqOp) -- can't handle SeqOp
getArgAmodes args `thenFC` \ arg_amodes ->
= getArgAmodes args `thenFC` \ arg_amodes ->
case (getPrimOpResultInfo primop) of
......
......@@ -64,7 +64,7 @@ The goal of this pass is to prepare for code generation.
4. Ensure that lambdas only occur as the RHS of a binding
(The code generator can't deal with anything else.)
5. Do the seq/par munging. See notes with mkCase below.
5. [Not any more; nuked Jun 2002] Do the seq/par munging.
6. Clone all local Ids.
This means that all such Ids are unique, rather than the
......@@ -359,7 +359,7 @@ corePrepExprFloat env (Case scrut bndr alts)
= corePrepExprFloat env scrut `thenUs` \ (floats, scrut') ->
cloneBndr env bndr `thenUs` \ (env', bndr') ->
mapUs (sat_alt env') alts `thenUs` \ alts' ->
returnUs (floats, mkCase scrut' bndr' alts')
returnUs (floats, Case scrut' bndr' alts')
where
sat_alt env (con, bs, rhs)
= cloneBndrs env bs `thenUs` \ (env', bs') ->
......@@ -532,7 +532,7 @@ mkBinds binds body
| otherwise = deLam body `thenUs` \ body' ->
returnUs (foldrOL mk_bind body' binds)
where
mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
mk_bind (FloatCase bndr rhs _) body = Case rhs bndr [(DEFAULT, [], body)]
mk_bind (FloatLet bind) body = Let bind body
etaExpandRhs bndr rhs
......@@ -635,55 +635,6 @@ tryEta bndrs _ = Nothing
\end{code}
-- -----------------------------------------------------------------------------
-- Do the seq and par transformation
-- -----------------------------------------------------------------------------
Here we do two pre-codegen transformations:
1. case seq# a of {
0 -> seqError ...
DEFAULT -> rhs }
==>
case a of { DEFAULT -> rhs }
2. case par# a of {
0 -> parError ...
DEFAULT -> rhs }
==>
case par# a of {
DEFAULT -> rhs }
NB: seq# :: a -> Int# -- Evaluate value and return anything
par# :: a -> Int# -- Spark value and return anything
These transformations can't be done earlier, or else we might
think that the expression was strict in the variables in which
rhs is strict --- but that would defeat the purpose of seq and par.
\begin{code}
mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
-- DEFAULT alt is always first
= case isPrimOpId_maybe fn of
Just ParOp -> Case scrut bndr [deflt_alt]
Just SeqOp -> Case arg new_bndr [deflt_alt]
other -> Case scrut bndr alts
where
-- The binder shouldn't be used in the expression!
new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
setIdType bndr (exprType arg)
-- NB: SeqOp :: forall a. a -> Int#
-- So bndr has type Int#
-- But now we are going to scrutinise the SeqOp's argument directly,
-- so we must change the type of the case binder to match that
-- of the argument expression e.
mkCase scrut bndr alts = Case scrut bndr alts
\end{code}
-- -----------------------------------------------------------------------------
-- Demands
-- -----------------------------------------------------------------------------
......
......@@ -949,6 +949,7 @@ runMainKey = mkPreludeMiscIdUnique 56
andIdKey = mkPreludeMiscIdUnique 57
orIdKey = mkPreludeMiscIdUnique 58
thenIOIdKey = mkPreludeMiscIdUnique 59
lazyIdKey = mkPreludeMiscIdUnique 60
-- Parallel array functions
nullPIdKey = mkPreludeMiscIdUnique 70
......
......@@ -66,7 +66,6 @@ primOpRules op = primop_rule op
-- ToDo: something for integer-shift ops?
-- NotOp
primop_rule SeqOp = one_rule seqRule
primop_rule TagToEnumOp = one_rule tagToEnumRule
primop_rule DataToTagOp = one_rule dataToTagRule
......@@ -357,66 +356,6 @@ mkDoubleVal d = Lit (convFloating (MachDouble d))
%* *
%************************************************************************
In the parallel world, we use _seq_ to control the order in which
certain expressions will be evaluated. Operationally, the expression
``_seq_ a b'' evaluates a and then evaluates b. We have an inlining
for _seq_ which translates _seq_ to:
_seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y }
Now, we know that the seq# primitive will never return 0#, but we
don't let the simplifier know that. We also use a special error
value, parError#, which is *not* a bottoming Id, so as far as the
simplifier is concerned, we have to evaluate seq# a before we know
whether or not y will be evaluated.
If we didn't have the extra case, then after inlining the compiler might
see:
f p q = case seq# p of { _ -> p+q }
If it sees that, it can see that f is strict in q, and hence it might
evaluate q before p! The "0# ->" case prevents this happening.
By having the parError# branch we make sure that anything in the
other branch stays there!
This is fine, but we'd like to get rid of the extraneous code. Hence,
we *do* let the simplifier know that seq# is strict in its argument.
As a result, we hope that `a' will be evaluated before seq# is called.
At this point, we have a very special and magical simpification which
says that ``seq# a'' can be immediately simplified to `1#' if we
know that `a' is already evaluated.
NB: If we ever do case-floating, we have an extra worry:
case a of
a' -> let b' = case seq# a of { True -> b; False -> parError# }
in case b' of ...
=>
case a of
a' -> let b' = case True of { True -> b; False -> parError# }
in case b' of ...
=>
case a of
a' -> let b' = b
in case b' of ...
=>
case a of
a' -> case b of ...
The second case must never be floated outside of the first!
\begin{code}
seqRule [Type ty, arg] | exprIsValue arg = Just (mkIntVal 1)
seqRule other = Nothing
\end{code}
\begin{code}
tagToEnumRule [Type ty, Lit (MachInt i)]
= ASSERT( isEnumerationTyCon tycon )
......
-----------------------------------------------------------------------
-- $Id: primops.txt.pp,v 1.19 2002/05/01 13:16:04 simonmar Exp $
-- $Id: primops.txt.pp,v 1.20 2002/06/18 13:58:24 simonpj Exp $
--
-- Primitive Operations
--
......@@ -1534,14 +1534,6 @@ primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
section "Parallelism"
------------------------------------------------------------------------
primop SeqOp "seq#" GenPrimOp
a -> Int#
with
usage = { mangle SeqOp [mkO] mkR }
strictness = { \ arity -> mkStrictSig (mkTopDmdType [evalDmd] TopRes) }
-- Seq is strict in its argument; see notes in ConFold.lhs
has_side_effects = True
primop ParOp "par#" GenPrimOp
a -> Int#
with
......
......@@ -12,10 +12,11 @@ import CoreSyn
import CoreUnfold ( certainlyWillInline )
import CoreLint ( showPass, endPass )
import CoreUtils ( exprType, exprIsValue )
import Id ( Id, idType, isOneShotLambda,
import Id ( Id, idType, isOneShotLambda,
setIdNewStrictness, mkWorkerId,
setIdWorkerInfo, setInlinePragma,
idInfo )
import MkId ( lazyIdKey, lazyIdUnfolding )
import Type ( Type )
import IdInfo ( WorkerInfo(..), arityInfo,
newDemandInfo, newStrictnessInfo, unfoldingInfo, inlinePragInfo
......@@ -24,6 +25,7 @@ import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent
)
import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
import Unique ( hasKey )
import BasicTypes ( RecFlag(..), isNonRec, Activation(..) )
import VarEnv ( isEmptyVarEnv )
import Maybes ( orElse )
......@@ -127,9 +129,16 @@ matching by looking for strict arguments of the correct type.
\begin{code}
wwExpr :: CoreExpr -> UniqSM CoreExpr
wwExpr e@(Type _) = returnUs e
wwExpr e@(Var _) = returnUs e
wwExpr e@(Lit _) = returnUs e
wwExpr e@(Type _) = returnUs e
wwExpr e@(Lit _) = returnUs e
wwExpr e@(Note InlineMe expr) = returnUs expr
-- Don't w/w inside InlineMe's
wwExpr e@(Var v)
| v `hasKey` lazyIdKey = returnUs lazyIdUnfolding
| otherwise = returnUs e
-- Inline 'lazy' after strictness analysis
-- (but not inside InlineMe's)
wwExpr (Lam binder expr)
= wwExpr expr `thenUs` \ new_expr ->
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment