[project @ 2001-12-10 12:26:10 by simonpj]

------------------------------
	Don't do CPR w/w for constants
	------------------------------

We don't want to do a CPR split for a constant
function.  So if the worker will get no (value) args,
we disable the CPR transformation.

This infelicity exposed a buglet in the full laziness
transformation; we were floating an expression outside
an InlineMe context.   I've take the blunderbuss approach
now, of effectively disabling full laziness inside an
InlineMe.  Seems reasonable.

diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index 6cd9efb..dc31910 100644 (file)
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -125,11 +125,19 @@ tOP_LEVEL   = Level 0 0
 iNLINE_CTXT = InlineCtxt
 
 incMajorLvl :: Level -> Level
-incMajorLvl InlineCtxt                 = Level 1 0
+-- For InlineCtxt we ignore any inc's; we don't want
+-- to do any floating at all.  For example,
+--     f = __inline__ (\x -> g 3)
+-- Don't float the (g 3) because that will stop it being
+-- inlined.  One particular case is that of workers: we don't
+-- want to float the call to the worker outside the wrapper,
+-- otherwise the worker might get inlined into the floated expression, 
+-- and an importing module won't see the worker at all.
+incMajorLvl InlineCtxt         = InlineCtxt
 incMajorLvl (Level major minor) = Level (major+1) 0
 
 incMinorLvl :: Level -> Level
-incMinorLvl InlineCtxt                 = Level 0 1
+incMinorLvl InlineCtxt         = InlineCtxt
 incMinorLvl (Level major minor) = Level major (minor+1)
 
 maxLvl :: Level -> Level -> Level

diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index 996907d..0c28388 100644 (file)
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -121,14 +121,21 @@ mkWwBodies :: Type                                -- Type of original function
 
 mkWwBodies fun_ty demands res_info one_shots
   = mkWWargs fun_ty demands one_shots' `thenUs` \ (wrap_args,   wrap_fn_args, work_fn_args, res_ty) ->
-    mkWWcpr res_ty res_info            `thenUs` \ (wrap_fn_cpr, work_fn_cpr,  cpr_res_ty) ->
     mkWWstr wrap_args                  `thenUs` \ (work_args,   wrap_fn_str,  work_fn_str) ->
     let
-       (work_lam_args, work_call_args) = mkWorkerArgs work_args cpr_res_ty
+       (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty
     in
+       -- Don't do CPR if the worker doesn't have any value arguments
+       -- Then the worker is just a constant, so we don't want to unbox it.
+    (if any isId work_args then
+       mkWWcpr res_ty res_info
+     else
+       returnUs (id, id, res_ty)
+    )                                  `thenUs` \ (wrap_fn_cpr, work_fn_cpr,  cpr_res_ty) ->
+
     returnUs ([idNewDemandInfo v | v <- work_args, isId v],
              Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var,
-             mkLams work_lam_args . work_fn_str . work_fn_cpr . work_fn_args)
+             mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args)
        -- We use an INLINE unconditionally, even if the wrapper turns out to be
        -- something trivial like
        --      fw = ...
@@ -151,7 +158,7 @@ During worker-wrapper stuff we may end up with an unlifted thing
 which we want to let-bind without losing laziness.  So we
 add a void argument.  E.g.
 
-       f = /\a -> \x y z -> E::Int#    -- E does not mentione x,y,z
+       f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z
 ==>
        fw = /\ a -> \void -> E
        f  = /\ a -> \x y z -> fw realworld
@@ -418,8 +425,9 @@ mkWWcpr body_ty RetCPR
       let
        work_wild = mk_ww_local work_uniq body_ty
        arg       = mk_ww_local arg_uniq  con_arg_ty1
+       con_app   = mkConApp data_con (map Type tycon_arg_tys ++ [Var arg])
       in
-      returnUs (\ wkr_call -> Case wkr_call arg [(DEFAULT, [], mkConApp data_con (map Type tycon_arg_tys ++ [Var arg]))],
+      returnUs (\ wkr_call -> Case wkr_call arg [(DEFAULT, [], con_app)],
                \ body     -> workerCase body work_wild [(DataAlt data_con, [arg], Var arg)],
                con_arg_ty1)