From 7614497c29c35f1e6da27efdb7762ad4e0c6a422 Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 31 Aug 2001 14:40:31 +0000 Subject: [PATCH] [project @ 2001-08-31 14:40:31 by simonmar] Fix worker-wrapper generation. See commments in WwLib.mk_ww_str --- ghc/compiler/stranal/DmdAnal.lhs | 14 ++------- ghc/compiler/stranal/WwLib.lhs | 64 ++++++++++++++++++++++++++++---------- 2 files changed, 51 insertions(+), 27 deletions(-) diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs index e2b3ed9..cc4916b 100644 --- a/ghc/compiler/stranal/DmdAnal.lhs +++ b/ghc/compiler/stranal/DmdAnal.lhs @@ -7,7 +7,7 @@ ----------------- \begin{code} -module DmdAnal ( dmdAnalPgm ) where +module DmdAnal ( dmdAnalPgm, both {- needed by WwLib -} ) where #include "HsVersions.h" @@ -174,7 +174,6 @@ dmdAnal sigs dmd (Case scrut case_bndr [alt@(DataAlt dc,bndrs,rhs)]) isProductTyCon tycon, not (isRecursiveTyCon tycon) = let - bndr_ids = filter isId bndrs (alt_ty, alt') = dmdAnalAlt sigs dmd alt (alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr (_, bndrs', _) = alt' @@ -301,8 +300,8 @@ dmdFix top_lvl sigs pairs where (sigs', lazy_fv1, pair') = downRhs top_lvl sigs (id,rhs) lazy_fv' = plusUFM_C both lazy_fv lazy_fv1 - old_sig = lookup sigs id - new_sig = lookup sigs' id + -- old_sig = lookup sigs id + -- new_sig = lookup sigs' id -- Get an initial strictness signature from the Id -- itself. That way we make use of earlier iterations @@ -787,13 +786,6 @@ boths ds1 [] = ds1 boths ds1 ds2 = ASSERT( length ds1 == length ds2 ) zipWith both ds1 ds2 ----------------------------------- -bothRes :: DmdResult -> DmdResult -> DmdResult --- Left-biased for CPR info -bothRes BotRes _ = BotRes -bothRes _ BotRes = BotRes -bothRes r1 _ = r1 - ------------------------------------ -- (t1 `bothType` t2) takes the argument/result info from t1, -- using t2 just for its free-var info bothType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2) diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 54248a7..2cad15a 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -11,12 +11,13 @@ module WwLib ( mkWwBodies ) where import CoreSyn import CoreUtils ( exprType ) import Id ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo, - isOneShotLambda, setOneShotLambda, + isOneShotLambda, setOneShotLambda, setIdUnfolding, setIdInfo ) import IdInfo ( vanillaIdInfo ) import DataCon ( splitProductType_maybe, splitProductType ) -import NewDemand ( Demand(..), Keepity(..), DmdResult(..) ) +import NewDemand ( Demand(..), Keepity(..), DmdResult(..), isAbsentDmd ) +import DmdAnal ( both ) import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID, eRROR_CSTRING_ID ) import TysPrim ( realWorldStatePrimTy ) import TysWiredIn ( tupleCon ) @@ -24,7 +25,7 @@ import Type ( Type, isUnLiftedType, mkFunTys, splitForAllTys, splitFunTys, splitNewType_maybe, isAlgType ) import Literal ( Literal(MachStr) ) -import BasicTypes ( Arity, Boxity(..) ) +import BasicTypes ( Boxity(..) ) import Var ( Var, isId ) import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs, UniqSM ) import Util ( zipWithEqual ) @@ -319,14 +320,28 @@ mk_ww_str (arg : ds) returnUs (worker_args, wrap_fn, mk_absent_let arg . work_fn) -- Seq and keep - Seq Keep _ [] -> mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) -> - returnUs (arg : worker_args, mk_seq_case arg . wrap_fn, work_fn) - -- Pass the arg, no need to rebox - - -- Seq and discard - Seq Drop _ [] -> mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) -> - returnUs (worker_args, mk_seq_case arg . wrap_fn, mk_absent_let arg . work_fn) - -- Don't pass the arg, build absent arg + Seq _ _ cs + | all isAbsentDmd cs + -> mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) -> + let + arg_w_unf = arg `setIdUnfolding` mkOtherCon [] + -- Tell the worker arg that it's sure to be evaluated + -- so that internal seqs can be dropped + in + returnUs (arg_w_unf : worker_args, mk_seq_case arg . wrap_fn, work_fn) + -- Pass the arg, anyway, even if it is in theory discarded + -- Consider + -- f x y = x `seq` y + -- x gets a (Seq Drop []) demand, but if we fail to pass it to the worker + -- we ABSOLUTELY MUST record that x is evaluated in the wrapper. + -- Something like: + -- f x y = x `seq` fw y + -- fw y = let x{Evald} = error "oops" in (x `seq` y) + -- If we don't pin on the "Evald" flag, the seq doesn't disappear, and + -- we end up evaluating the absent thunk. + -- But the Evald flag is pretty wierd, and I worry that it might disappear + -- during simplification, so for now I've just nuked this whole case + -- Unpack case Seq keep _ cs @@ -335,15 +350,32 @@ mk_ww_str (arg : ds) -> getUniquesUs `thenUs` \ uniqs -> let unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys - unpk_args_w_ds = zipWithEqual "mk_ww_str" set_worker_arg_info unpk_args cs + unpk_args_w_ds = zipWithEqual "mk_ww_str" set_worker_arg_info unpk_args cs' unbox_fn = mk_unpk_case arg unpk_args data_con arg_tycon rebox_fn = mk_pk_let arg data_con tycon_arg_tys unpk_args + + cs' = case keep of + Keep -> map (DmdAnal.both Lazy) cs -- Careful! Now we don't pass + -- the box, we must pass all the + -- components. In effect + -- S(LA) --> U(LL) + Drop -> cs in mk_ww_str (unpk_args_w_ds ++ ds) `thenUs` \ (worker_args, wrap_fn, work_fn) -> - case keep of - Keep -> returnUs (arg : worker_args, unbox_fn . wrap_fn, work_fn) - -- Pass the arg, no need to rebox - Drop -> returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) + +-- case keep of +-- Keep -> returnUs (arg : worker_args, unbox_fn . wrap_fn, work_fn) +-- -- Pass the arg, no need to rebox +-- Drop -> returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) +-- -- Don't pass the arg, rebox instead +-- I used to be clever here, but consider +-- f n [] = n +-- f n (x:xs) = f (n+x) xs +-- Here n gets (Seq Keep [L]), but it's BAD BAD BAD to pass both n and n# +-- Needs more thought, but the simple thing to do is to accept the reboxing +-- stuff if there are any non-absent arguments (and that case is dealt with above): + + returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) -- Don't pass the arg, rebox instead | otherwise -> -- 1.7.10.4