Commit f016a43f authored by simonpj's avatar simonpj

[project @ 1999-05-28 19:24:26 by simonpj]

Enable rules for simplification of SeqOp

Fix a related bug in WwLib that made it look as if the binder
in a case expression was being demanded, when it wasn't.
parent 29ad936c
......@@ -463,8 +463,8 @@ instance Eq Name where
a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
instance Ord Name where
a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
compare a b = cmpName a b
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgTailCall.lhs,v 1.19 1999/05/13 17:30:58 simonm Exp $
% $Id: CgTailCall.lhs,v 1.20 1999/05/28 19:24:28 simonpj Exp $
%
%********************************************************
%* *
......@@ -47,7 +47,7 @@ import CmdLineOpts ( opt_DoSemiTagging )
import Id ( Id, idType, idName )
import DataCon ( DataCon, dataConTyCon, dataConTag, fIRST_TAG )
import Const ( mkMachInt )
import Maybes ( assocMaybe )
import Maybes ( assocMaybe, maybeToBool )
import PrimRep ( PrimRep(..) )
import StgSyn ( StgArg, GenStgArg(..) )
import Type ( isUnLiftedType )
......@@ -390,7 +390,8 @@ doTailCall
-> (Sequel->Code) -- code to perform jump
-> Int -- number of "fast" stack arguments
-> AbstractC -- pending assignments
-> Maybe VirtualSpOffset -- sp offset to trim stack to
-> Maybe VirtualSpOffset -- sp offset to trim stack to:
-- USED iff destination is a let-no-escape
-> Bool -- node points to the closure to enter
-> Code
......@@ -449,7 +450,13 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts
-- push a return address if necessary
-- (after the assignments above, in case we clobber a live
-- stack location)
pushReturnAddress eob `thenC`
-- DONT push the return address when we're about
-- to jump to a let-no-escape: the final tail call
-- in the let-no-escape will do this.
(if (maybeToBool maybe_join_sp)
then nopC
else pushReturnAddress eob) `thenC`
-- Final adjustment of stack pointer
adjustRealSp final_sp `thenC`
......
......@@ -379,6 +379,7 @@ checkAllCasesCovered e scrut_ty alts
if isPrimTyCon tycon then
checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
else
{- No longer needed
#ifdef DEBUG
-- Algebraic cases are not necessarily exhaustive, because
-- the simplifer correctly eliminates case that can't
......@@ -398,6 +399,7 @@ checkAllCasesCovered e scrut_ty alts
nopL
else
#endif
-}
nopL }
hasDefault [] = False
......
This diff is collapsed.
This diff is collapsed.
......@@ -21,7 +21,8 @@ import TysWiredIn ( trueDataCon, falseDataCon )
import TyCon ( tyConDataCons, isEnumerationTyCon )
import DataCon ( dataConTag, fIRST_TAG )
import Const ( conOkForAlt )
import CoreUnfold ( Unfolding(..) )
import CoreUnfold ( Unfolding(..), isEvaldUnfolding )
import CoreUtils ( exprIsValue )
import Type ( splitTyConApp_maybe )
import Char ( ord, chr )
......@@ -89,13 +90,13 @@ NB: If we ever do case-floating, we have an extra worry:
The second case must never be floated outside of the first!
\begin{code}p
tryPrimOp SeqOp [Type ty, Con (Literal lit) _]
\begin{code}
tryPrimOp SeqOp [Type ty, arg]
| is_evald arg
= Just (Con (Literal (mkMachInt 1)) [])
tryPrimOp SeqOp args@[Type ty, Var var]
| isEvaluated (getIdUnfolding var) = Just (Con (Literal (mkMachInt 1)) [])) -- var is eval'd
| otherwise = Nothing -- var not eval'd
where
is_evald (Var v) = isEvaldUnfolding (getIdUnfolding v)
is_evald arg = exprIsValue arg
\end{code}
\begin{code}
......
This diff is collapsed.
......@@ -463,10 +463,16 @@ coreExprToStgFloat env expr@(Lam _ _) dem
\begin{code}
coreExprToStgFloat env expr@(App _ _) dem
= let
(fun,rads,_,_) = collect_args expr
ads = reverse rads
(fun,rads,_,ss) = collect_args expr
ads = reverse rads
final_ads | null ss = ads
| otherwise = zap ads -- Too few args to satisfy strictness info
-- so we have to ignore all the strictness info
-- e.g. + (error "urk")
-- Here, we can't evaluate the arg strictly,
-- because this partial application might be seq'd
in
coreArgsToStg env ads `thenUs` \ (arg_floats, stg_args) ->
coreArgsToStg env final_ads `thenUs` \ (arg_floats, stg_args) ->
-- Now deal with the function
case (fun, stg_args) of
......@@ -504,12 +510,11 @@ coreExprToStgFloat env expr@(App _ _) dem
collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
in (the_fun,ads,applyTy fun_ty tyarg,ss)
collect_args (App fun arg)
= case ss of
[] -> -- Strictness info has run out
(the_fun, (arg, mkDemTy wwLazy arg_ty) : zap ads, res_ty, repeat wwLazy)
(ss1:ss_rest) -> -- Enough strictness info
(the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
= (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
where
(ss1, ss_rest) = case ss of
(ss1:ss_rest) -> (ss1, ss_rest)
[] -> (wwLazy, [])
(the_fun, ads, fun_ty, ss) = collect_args fun
(arg_ty, res_ty) = expectJust "coreExprToStgFloat:collect_args" $
splitFunTy_maybe fun_ty
......@@ -582,33 +587,68 @@ coreExprToStgFloat env expr@(Con con args) dem
%* *
%************************************************************************
Mangle cases involving seq# in the discriminant. Up to this
point, seq# will appear like this:
First, two special cases. We mangle cases involving
par# and seq#
inthe scrutinee.
Up to this point, seq# will appear like this:
case seq# e of
0# -> seqError#
_ -> ...
_ -> <stuff>
This code comes from an unfolding for 'seq' in Prelude.hs.
The 0# branch is purely to bamboozle the strictness analyser.
For example, if <stuff> is strict in x, and there was no seqError#
branch, the strictness analyser would conclude that the whole expression
was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
where the 0# branch is purely to bamboozle the strictness analyser
This code comes from an unfolding for 'seq' in Prelude.hs. We
translate this into
Now that the evaluation order is safe, we translate this into
case e of
_ -> ...
Now that the evaluation order is safe.
This used to be done in the post-simplification phase, but we need
unfoldings involving seq# to appear unmangled in the interface file,
hence we do this mangling here.
Similarly, par# has an unfolding in PrelConc.lhs that makes it show
up like this:
case par# e of
0# -> rhs
_ -> parError#
==>
case par# e of
_ -> rhs
fork# isn't handled like this - it's an explicit IO operation now.
The reason is that fork# returns a ThreadId#, which gets in the
way of the above scheme. And anyway, IO is the only guaranteed
way to enforce ordering --SDM.
\begin{code}
coreExprToStgFloat env
(Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts) dem
= coreExprToStgFloat env (Case e new_bndr [(DEFAULT,[],default_rhs)]) dem
where new_bndr = setIdType bndr ty
(other_alts, maybe_default) = findDefault alts
Just default_rhs = maybe_default
where
new_bndr = setIdType bndr ty
(other_alts, maybe_default) = findDefault alts
Just default_rhs = maybe_default
coreExprToStgFloat env
(Case scrut@(Con (PrimOp ParOp) args) bndr alts) dem
| maybeToBool maybe_default
= coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') ->
newEvaldLocalId env bndr `thenUs` \ (env', bndr') ->
coreExprToStg env' default_rhs dem `thenUs` \ default_rhs' ->
returnUs (binds, mkStgCase scrut' bndr' (StgPrimAlts (idType bndr) [] (StgBindDefault default_rhs')))
where
(other_alts, maybe_default) = findDefault alts
Just default_rhs = maybe_default
\end{code}
Now for normal case expressions...
......
......@@ -632,7 +632,9 @@ findStrictness tys str_val abs_val
where
tys_w_index = tys `zip` [(1::Int) ..]
find_str (ty,n) = findRecDemand str_fn abs_fn ty
find_str (ty,n) = -- let res =
-- in pprTrace "findStr" (ppr ty <+> int n <+> ppr res) res
findRecDemand str_fn abs_fn ty
where
str_fn val = foldl (absApply StrAnal) str_val
(map (mk_arg val n) tys_w_index)
......
......@@ -328,7 +328,8 @@ addStrictnessInfoToId str_val abs_val binder body
-- We could use 'collectBindersIgnoringNotes', but then the
-- strictness info may have more items than the visible binders
-- used by WorkWrap.tryWW
(binders, rhs) -> binder `setIdStrictness`
(binders, rhs) -> -- pprTrace "addStr" (ppr binder $$ ppr strictness) $
binder `setIdStrictness`
mkStrictnessInfo strictness
where
tys = [idType id | id <- binders, isId id]
......
......@@ -15,8 +15,9 @@ module WwLib (
import CoreSyn
import Id ( Id, idType, mkSysLocal, getIdDemandInfo, setIdDemandInfo,
mkWildId )
import IdInfo ( CprInfo(..), noCprInfo )
mkWildId, setIdInfo
)
import IdInfo ( CprInfo(..), noCprInfo, vanillaIdInfo )
import Const ( Con(..), DataCon )
import DataCon ( dataConArgTys )
import Demand ( Demand(..) )
......@@ -561,14 +562,27 @@ mk_unpk_case NewType arg unpk_args boxing_con boxing_tycon body
-- A newtype! Use a coercion not a case
= ASSERT( null other_args )
Case (Note (Coerce (idType unpk_arg) (idType arg)) (Var arg))
unpk_arg
(sanitiseCaseBndr unpk_arg)
[(DEFAULT,[],body)]
where
(unpk_arg:other_args) = unpk_args
mk_unpk_case DataType arg unpk_args boxing_con boxing_tycon body
-- A data type
= Case (Var arg) arg [(DataCon boxing_con, unpk_args, body)]
= Case (Var arg)
(sanitiseCaseBndr arg)
[(DataCon boxing_con, unpk_args, body)]
sanitiseCaseBndr :: Id -> Id
-- The argument we are scrutinising has the right type to be
-- a case binder, so it's convenient to re-use it for that purpose.
-- But we *must* throw away all its IdInfo. In particular, the argument
-- will have demand info on it, and that demand info may be incorrect for
-- the case binder. e.g. case ww_arg of ww_arg { I# x -> ... }
-- Quite likely ww_arg isn't used in '...'. The case may get discarded
-- if the case binder says "I'm demanded". This happened in a situation
-- like (x+y) `seq` ....
sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
mk_pk_let NewType arg boxing_con con_tys unpk_args body
= ASSERT( null other_args )
......
......@@ -39,7 +39,7 @@ import Id ( getIdUnfolding )
import CoreUnfold ( getUnfoldingTemplate )
import FieldLabel
import Var ( Id, TyVar )
import Name ( Name, isLocallyDefined, OccName, NamedThing(..) )
import Name ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique )
import Outputable
import TyCon ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon, isAlgTyCon,
isSynTyCon, tyConDataCons, isNewTyCon
......@@ -303,7 +303,18 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
-- Check that all the fields in the group have the same type
-- This check assumes that all the constructors of a given
-- data type use the same type variables
= checkTc (all (== field_ty) other_tys)
= (if null other_fields then (\x->x) else
let lbls = [fieldLabelName f | (_,f) <- fields]
uniqs = [nameUnique l | l <- lbls]
in
pprTrace "mkRecordSelector" (vcat [ppr fields,
ppr lbls,
ppr uniqs,
hsep [text (show (field_name `compare` fieldLabelName f)) | (_,f) <- fields]
]))
checkTc (all (== field_ty) other_tys)
(fieldTypeMisMatch field_name) `thenTc_`
returnTc selector_id
where
......
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