[project @ 2001-09-14 15:49:56 by simonpj]

-----------------
	Make seq built in
	-----------------

	DO NOT merge with stable

Until this commit 'seq' used a cunning hack so that it
seems to be *non-strict* in its second argument:

  seq x y = case seq# x of { 0 -> y; other -> error "urk" }

The reason for this is to make sure that x is evaluated before y,
which is what you want in a parallel setting.

But in a *sequential* settting, this simply destroys strictness
information about y.  Now that people are starting to use seq more,
this is becoming painful.  People sometimes use seq to make their
function strict, and are surprised when it becomes non-strict in other
arguments!

So this commit changes seq so that it does what you would naively
expect:

	seq x y = case x of { any -> y }

This is done by making seq built-in, defined along with
	unsafeCoerce
	getTag

in MkId.lhs.  (I considered giving their unfoldings in
PrelGHC.hi-boot.pp, but then there is the matter of making sure they
are unfolded, since these fns don't have top-level curried defns,
so I held off and did seq the same way as the other two.)

I renamed PrelConc.seq as PrelConc.pseq; maybe its name will change
to `then` or `before` or something else.  That's up to the GPH
folk.

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index f1483e9..32f72dc 100644 (file)
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -32,11 +32,11 @@ module MkId (
 
 
 import BasicTypes      ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
-import TysPrim         ( openAlphaTyVars, alphaTyVar, alphaTy, 
+import TysPrim         ( openAlphaTyVars, alphaTyVar, alphaTy, betaTyVar, betaTy,
                          intPrimTy, realWorldStatePrimTy, addrPrimTy
                        )
 import TysWiredIn      ( charTy, mkListTy )
-import PrelRules       ( primOpRule )
+import PrelRules       ( primOpRules )
 import Rules           ( addRule )
 import TcType          ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
                          mkTyVarTys, mkClassPred, tcEqPred,
@@ -125,6 +125,7 @@ wiredInIds
     , realWorldPrimId
     , unsafeCoerceId
     , getTagId
+    , seqId
     ]
 \end{code}
 
@@ -146,8 +147,24 @@ mkDataConId work_name data_con
           `setArityInfo`               arity
           `setNewStrictnessInfo`       Just strict_sig
 
-    arity = dataConRepArity data_con
+    arity      = dataConRepArity data_con
+
     strict_sig = mkStrictSig (mkTopDmdType (replicate arity topDmd) cpr_info)
+       -- Notice that we do *not* say the worker is strict
+       -- even if the data constructor is declared strict
+       --      e.g.    data T = MkT !(Int,Int)
+       -- Why?  Because the *wrapper* is strict (and its unfolding has case
+       -- expresssions that do the evals) but the *worker* itself is not.
+       -- If we pretend it is strict then when we see
+       --      case x of y -> $wMkT y
+       -- the simplifier thinks that y is "sure to be evaluated" (because
+       -- $wMkT is strict) and drops the case.  No, $wMkT is not strict.
+       --
+       -- When the simplifer sees a pattern 
+       --      case e of MkT x -> ...
+       -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
+       -- but that's fine... dataConRepStrictness comes from the data con
+       -- not from the worker Id.
 
     tycon = dataConTyCon data_con
     cpr_info | isProductTyCon tycon && 
@@ -222,9 +239,7 @@ mkDataConWrapId data_con
                -- applications are treated as values
           `setNewStrictnessInfo`       Just wrap_sig
 
-    wrap_ty = mkForAllTys all_tyvars $
-             mkFunTys all_arg_tys
-             result_ty
+    wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty)
 
     res_info = strictSigResInfo (idNewStrictness work_id)
     wrap_sig = mkStrictSig (mkTopDmdType (replicate arity topDmd) res_info)
@@ -619,8 +634,7 @@ mkPrimOpId prim_op
           `setNewStrictnessInfo`       Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo)
        -- Until we modify the primop generation code
 
-    rules = maybe emptyCoreRules (addRule emptyCoreRules id)
-               (primOpRule prim_op)
+    rules = foldl (addRule id) emptyCoreRules (primOpRules prim_op)
 
 
 -- For each ccall we manufacture a separate CCallOpId, giving it
@@ -740,7 +754,12 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta
 %*                                                                     *
 %************************************************************************
 
-These two can't be defined in Haskell.
+These Ids can't be defined in Haskell.  They could be defined in 
+unfoldings in PrelGHC.hi-boot, but we'd have to ensure that they
+were definitely, definitely inlined, because there is no curried
+identifier for them.  Thats what mkCompulsoryUnfolding does.
+If we had a way to get a compulsory unfolding from an interface file,
+we could do that, but we don't right now.
 
 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
 just gets expanded into a type coercion wherever it occurs.  Hence we
@@ -762,8 +781,18 @@ unsafeCoerceId
     [x] = mkTemplateLocals [openAlphaTy]
     rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
          Note (Coerce openBetaTy openAlphaTy) (Var x)
-\end{code}
 
+seqId
+  = pcMiscPrelId seqIdKey pREL_GHC SLIT("seq") ty info
+  where
+    info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+          
+
+    ty  = mkForAllTys [alphaTyVar,betaTyVar]
+                     (mkFunTy alphaTy (mkFunTy betaTy betaTy))
+    [x,y] = mkTemplateLocals [alphaTy, betaTy]
+    rhs = mkLams [alphaTyVar,betaTyVar,x] (Case (Var x) x [(DEFAULT, [], Var y)])
+\end{code}
 
 @getTag#@ is another function which can't be defined in Haskell.  It needs to
 evaluate its argument and call the dataToTag# primitive.

diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs
index a0d34b5..67b36a8 100644 (file)
--- a/ghc/compiler/prelude/PrelNames.lhs
+++ b/ghc/compiler/prelude/PrelNames.lhs
@@ -812,6 +812,7 @@ integerPlusOneIdKey       = mkPreludeMiscIdUnique 10
 integerPlusTwoIdKey          = mkPreludeMiscIdUnique 11
 integerZeroIdKey             = mkPreludeMiscIdUnique 12
 int2IntegerIdKey             = mkPreludeMiscIdUnique 13
+seqIdKey                     = mkPreludeMiscIdUnique 14
 irrefutPatErrorIdKey         = mkPreludeMiscIdUnique 15
 eqStringIdKey                = mkPreludeMiscIdUnique 16
 noMethodBindingErrorIdKey     = mkPreludeMiscIdUnique 17

diff --git a/ghc/lib/std/PrelConc.lhs b/ghc/lib/std/PrelConc.lhs
index 0ffe3a9..e011060 100644 (file)
--- a/ghc/lib/std/PrelConc.lhs
+++ b/ghc/lib/std/PrelConc.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: PrelConc.lhs,v 1.24 2001/05/18 16:54:05 simonmar Exp $
+% $Id: PrelConc.lhs,v 1.25 2001/09/14 15:49:56 simonpj Exp $
 %
 % (c) The University of Glasgow, 1994-2000
 %
@@ -19,7 +19,7 @@ module PrelConc
        , killThread    -- :: ThreadId -> IO ()
        , throwTo       -- :: ThreadId -> Exception -> IO ()
        , par           -- :: a -> b -> b
-       , seq           -- :: a -> b -> b
+       , pseq          -- :: a -> b -> b
        , yield         -- :: IO ()
 
        -- Waiting
@@ -47,7 +47,7 @@ import PrelIOBase     ( IO(..), MVar(..) )
 import PrelBase                ( Int(..) )
 import PrelException    ( Exception(..), AsyncException(..) )
 
-infixr 0 `par`, `seq`
+infixr 0 `par`, `pseq`
 \end{code}
 
 %************************************************************************
@@ -80,7 +80,10 @@ yield :: IO ()
 yield = IO $ \s -> 
    case (yield# s) of s1 -> (# s1, () #)
 
--- "seq" is defined a bit weirdly (see below)
+--     Nota Bene: 'pseq' used to be 'seq'
+--                but 'seq' is now defined in PrelGHC
+--
+-- "pseq" is defined a bit weirdly (see below)
 --
 -- The reason for the strange "0# -> parError" case is that
 -- it fools the compiler into thinking that seq is non-strict in
@@ -91,9 +94,9 @@ yield = IO $ \s ->
 -- Just before converting from Core to STG there's a bit of magic
 -- that recognises the seq# and eliminates the duff case.
 
-{-# INLINE seq  #-}
-seq :: a -> b -> b
-seq  x y = case (seq#  x) of { 0# -> seqError; _ -> y }
+{-# INLINE pseq  #-}
+pseq :: a -> b -> b
+pseq  x y = case (seq#  x) of { 0# -> seqError; _ -> y }
 
 {-# INLINE par  #-}
 par :: a -> b -> b

diff --git a/ghc/lib/std/PrelGHC.hi-boot.pp b/ghc/lib/std/PrelGHC.hi-boot.pp
index 5880ec1..c9c7ba4 100644 (file)
--- a/ghc/lib/std/PrelGHC.hi-boot.pp
+++ b/ghc/lib/std/PrelGHC.hi-boot.pp
@@ -51,6 +51,9 @@ __export PrelGHC
   tryPutMVarzh
   isEmptyMVarzh
 
+  -- Seq
+  seq
+
   -- Parallel
   seqzh
   parzh
@@ -463,3 +466,4 @@ instance __forall s => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh;
 1 zdfCCallableMutableByteArrayzh :: __forall s => {CCallable (MutableByteArrayzh s)} ;
 1 zdfCCallableForeignObjzh :: {CCallable ForeignObjzh} ;
 1 zdfCCallableStablePtrzh :: __forall a => {CCallable (StablePtrzh a)} ;
+