From 74a395c2cd036a82a17b3a6f3d33477ebadb66c2 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 14 Sep 2001 15:49:56 +0000 Subject: [PATCH] [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. --- ghc/compiler/basicTypes/MkId.lhs | 49 ++++++++++++++++++++++++++++-------- ghc/compiler/prelude/PrelNames.lhs | 1 + ghc/lib/std/PrelConc.lhs | 17 +++++++------ ghc/lib/std/PrelGHC.hi-boot.pp | 4 +++ 4 files changed, 54 insertions(+), 17 deletions(-) diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index f1483e9..32f72dc 100644 --- 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 --- 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 --- 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 --- 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)} ; + -- 1.7.10.4