[project @ 2001-08-31 14:40:31 by simonmar]

Fix worker-wrapper generation.  See commments in WwLib.mk_ww_str

diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs
index e2b3ed9..cc4916b 100644 (file)
--- 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 (file)
--- 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 ->