[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 }

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 9382d57..d8fab3c 100644 (file)
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -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,
        -- 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,
 
        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,
     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
     ] ++ 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)])
                      (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
 \end{code}
 
 @getTag#@ is another function which can't be defined in Haskell.  It needs to

diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 2076a07..2894de2 100644 (file)
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 %
 % (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
   = 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
 
 
     case (getPrimOpResultInfo primop) of
 

diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs
index 5b18681..6e109c8 100644 (file)
--- a/ghc/compiler/coreSyn/CorePrep.lhs
+++ b/ghc/compiler/coreSyn/CorePrep.lhs
@@ -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.)
 
 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 
 
 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' ->
   = 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') ->
   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
   | 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
     mk_bind (FloatLet bind)        body = Let bind body
 
 etaExpandRhs bndr rhs

@@ -636,55 +636,6 @@ tryEta bndrs _ = Nothing
 
 
 -- -----------------------------------------------------------------------------
 
 
 -- -----------------------------------------------------------------------------

---     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
 -- -----------------------------------------------------------------------------
 
 -- Demands
 -- -----------------------------------------------------------------------------
 

diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs
index dafee0d..b99e354 100644 (file)
--- a/ghc/compiler/prelude/PrelNames.lhs
+++ b/ghc/compiler/prelude/PrelNames.lhs
@@ -949,6 +949,7 @@ runMainKey                = mkPreludeMiscIdUnique 56
 andIdKey                     = mkPreludeMiscIdUnique 57
 orIdKey                              = mkPreludeMiscIdUnique 58
 thenIOIdKey                  = mkPreludeMiscIdUnique 59
 andIdKey                     = mkPreludeMiscIdUnique 57
 orIdKey                              = mkPreludeMiscIdUnique 58
 thenIOIdKey                  = mkPreludeMiscIdUnique 59

+lazyIdKey                    = mkPreludeMiscIdUnique 60

 
 -- Parallel array functions
 nullPIdKey                   = mkPreludeMiscIdUnique 70
 
 -- Parallel array functions
 nullPIdKey                   = mkPreludeMiscIdUnique 70

diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs
index 5f0981c..62b8cfc 100644 (file)
--- a/ghc/compiler/prelude/PrelRules.lhs
+++ b/ghc/compiler/prelude/PrelRules.lhs
@@ -66,7 +66,6 @@ primOpRules op = primop_rule op
     -- ToDo:   something for integer-shift ops?
     --         NotOp
 
     -- 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
 
     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 ) 
 \begin{code}
 tagToEnumRule [Type ty, Lit (MachInt i)]
   = ASSERT( isEnumerationTyCon tycon ) 

diff --git a/ghc/compiler/prelude/primops.txt.pp b/ghc/compiler/prelude/primops.txt.pp
index fc134c0..a1ff417 100644 (file)
--- a/ghc/compiler/prelude/primops.txt.pp
+++ b/ghc/compiler/prelude/primops.txt.pp
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------
 -----------------------------------------------------------------------

--- $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
 --
 --
 -- Primitive Operations
 --

@@ -1534,14 +1534,6 @@ primop  ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
 section "Parallelism"
 ------------------------------------------------------------------------
 
 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
 primop  ParOp "par#" GenPrimOp
    a -> Int#
    with

diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index 89417f4..2cdda70 100644 (file)
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -12,10 +12,11 @@ import CoreSyn
 import CoreUnfold      ( certainlyWillInline )
 import CoreLint                ( showPass, endPass )
 import CoreUtils       ( exprType, exprIsValue )
 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 )
                          setIdNewStrictness, mkWorkerId,
                          setIdWorkerInfo, setInlinePragma,
                          idInfo )

+import MkId            ( lazyIdKey, lazyIdUnfolding )

 import Type            ( Type )
 import IdInfo          ( WorkerInfo(..), arityInfo,
                          newDemandInfo, newStrictnessInfo, unfoldingInfo, inlinePragInfo
 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 )
                          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 )
 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
 
 \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 ->
 
 wwExpr (Lam binder expr)
   = wwExpr expr                        `thenUs` \ new_expr ->