From: simonpj <unknown>
Date: Thu, 25 Jan 2001 17:15:30 +0000 (+0000)
Subject: [project @ 2001-01-25 17:15:30 by simonpj]
X-Git-Tag: Approximately_9120_patches~2825
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e0d9dcf1e07758cd9cf3548681ca4c108bb23bf8;p=ghc-hetmet.git

[project @ 2001-01-25 17:15:30 by simonpj]
Arrange that we pass the real-world token *last* when
there are no arguments to a worker.  There might still
be type arguments, and most of GHC kind-of-expects the
type arguments to be first.
---

diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index 65e65e4..fdbc5e2 100644
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -224,15 +224,25 @@ mkWwBodies :: Type				-- Type of original function
 		      Id -> CoreExpr,		-- Wrapper body, lacking only the worker Id
 		      CoreExpr -> CoreExpr)	-- Worker body, lacking the original function rhs
 
+-- wrap_fn_args E	= \x y -> E
+-- work_fn_args E	= E x y
+
+-- wrap_fn_str E 	= case x of { (a,b) -> 
+--			  case a of { (a1,a2) ->
+--			  E a1 a2 b y }}
+-- work_fn_str E	= \a2 a2 b y ->
+--			  let a = (a1,a2) in
+--			  let x = (a,b) in
+--			  E
+
 mkWwBodies fun_ty arity demands res_bot one_shots cpr_info
   = mkWWargs fun_ty arity demands' res_bot one_shots'	`thenUs` \ (wrap_args, wrap_fn_args,   work_fn_args, res_ty) ->
-    mkWWstr wrap_args					`thenUs` \ (work_dmds, wrap_fn_str,    work_fn_str) ->
     mkWWcpr res_ty cpr_info      			`thenUs` \ (wrap_fn_cpr,    work_fn_cpr,  cpr_res_ty) ->
-    mkWWfixup cpr_res_ty work_dmds			`thenUs` \ (final_work_dmds, wrap_fn_fixup,  work_fn_fixup) ->
+    mkWWstr cpr_res_ty wrap_args			`thenUs` \ (work_dmds, wrap_fn_str,    work_fn_str) ->
 
-    returnUs (final_work_dmds,
-	      Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . wrap_fn_fixup . Var,
-	      work_fn_fixup . work_fn_str . work_fn_cpr . work_fn_args)
+    returnUs (work_dmds,
+	      Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . Var,
+	      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 = ...
@@ -345,42 +355,13 @@ mk_wrap_arg uniq ty dmd one_shot
 
 %************************************************************************
 %*									*
-\subsection{Fixup stuff}
-%*									*
-%************************************************************************
-
-\begin{code}
-mkWWfixup res_ty work_dmds
-  | null work_dmds && isUnLiftedType res_ty 
- 	-- Horrid special case.  If the worker would have no arguments, and the
-	-- function returns a primitive type value, that would make the worker into
-	-- an unboxed value.  We box it by passing a dummy void argument, thus:
-	--
-	--	f = /\abc. \xyz. fw abc void
-	-- 	fw = /\abc. \v. body
-	--
-	-- We use the state-token type which generates no code
-  = getUniqueUs 		`thenUs` \ void_arg_uniq ->
-    let
-	    void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy
-    in
-    returnUs ([wwPrim],		
-	      \ call_to_worker -> App call_to_worker (Var realWorldPrimId),
-	      \ worker_body    -> Lam void_arg worker_body)
-
-  | otherwise
-  = returnUs (work_dmds, id, id)
-\end{code}
-
-
-%************************************************************************
-%*									*
 \subsection{Strictness stuff}
 %*									*
 %************************************************************************
 
 \begin{code}
-mkWWstr :: [Var]				-- Wrapper args; have their demand info on them
+mkWWstr :: Type					-- Result type
+	-> [Var]				-- Wrapper args; have their demand info on them
 						-- *Includes type variables*
         -> UniqSM ([Demand],			-- Demand on worker (value) args
 		   CoreExpr -> CoreExpr,	-- Wrapper body, lacking the worker call
@@ -391,11 +372,32 @@ mkWWstr :: [Var]				-- Wrapper args; have their demand info on them
 		   CoreExpr -> CoreExpr)	-- Worker body, lacking the original body of the function,
 						-- but *with* lambdas
 
-mkWWstr wrap_args
-  = mk_ww_str wrap_args		`thenUs` \ (work_args, wrap_fn, work_fn) ->
-    returnUs ( [idDemandInfo v | v <- work_args, isId v],
-	       \ wrapper_body -> wrap_fn (mkVarApps wrapper_body work_args),
-	       \ worker_body  -> mkLams work_args (work_fn worker_body))
+mkWWstr res_ty wrap_args
+  = mk_ww_str wrap_args		`thenUs` \ (work_args, take_apart, put_together) ->
+    let
+	work_dmds = [idDemandInfo v | v <- work_args, isId v]
+	apply_to args fn = mkVarApps fn args
+    in
+    if not (null work_dmds && isUnLiftedType res_ty) then
+	returnUs ( work_dmds, 
+		   take_apart . apply_to work_args,
+		   mkLams work_args . put_together)
+    else
+ 	-- Horrid special case.  If the worker would have no arguments, and the
+	-- function returns a primitive type value, that would make the worker into
+	-- an unboxed value.  We box it by passing a dummy void argument, thus:
+	--
+	--	f = /\abc. \xyz. fw abc void
+	-- 	fw = /\abc. \v. body
+	--
+	-- We use the state-token type which generates no code
+    getUniqueUs 		`thenUs` \ void_arg_uniq ->
+    let
+	void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy
+    in
+    returnUs ([wwPrim],		
+	      take_apart . apply_to [realWorldPrimId] . apply_to work_args,
+	      mkLams work_args . Lam void_arg . put_together)
 
 	-- Empty case
 mk_ww_str []