From: simonpj <unknown>
Date: Mon, 10 Dec 2001 12:26:10 +0000 (+0000)
Subject: [project @ 2001-12-10 12:26:10 by simonpj]
X-Git-Tag: Approximately_9120_patches~434
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=7953d080ab53458e52ef7668816cef3a0ed42809;p=ghc-hetmet.git

[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
--- 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
--- 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)