[project @ 1999-07-14 22:10:40 by simonpj]

[Simon: this should fix that -funfolding-use-threshold0 lint bug]

[Kevin: have a look at WwLib.mkWwBodies.  Isn't it a thing of beauty?
	Could you think about whether the CPR stuff could be cleaned
	up a bit?  The strictness stuff is much shorter.]


This commit tidies up WwLib.mkWwBodies, fixing a couple of bugs.

* One bug showed up when CPR made a worker return an unboxed tuple,
  but the worker didn't have any other arguments.  The "add a void arg"
  hack needed to be generalised a bit.

* The other bug showed up when booting the compiler.  There's a long
  comment near splitProductType in WwLib.lhs that explains the problem.

ghc/compiler/cprAnalysis/CprAnalyse.lhs

@@ -379,9 +379,10 @@ splitFunTysIgnoringNewTypes ty = split ty
 		(args, res) = splitFunTys ty
 
 -- Is this the constructor for a product type (i.e. algebraic, single constructor) 
+-- NB: isProductTyCon replies 'False' for unboxed tuples
 isConProdType :: Con -> Bool
-isConProdType (DataCon con) = isProductTyCon tycon && not (isUnLiftedTyCon tycon)
-			      where
+isConProdType (DataCon con) = isProductTyCon tycon
+			    where
 			      tycon = dataConTyCon con
 isConProdType _ = False
 

ghc/compiler/stranal/WwLib.lhs

@@ -19,7 +19,7 @@ import Id		( Id, idType, mkSysLocal, getIdDemandInfo, setIdDemandInfo,
 			)
 import IdInfo		( CprInfo(..), noCprInfo, vanillaIdInfo )
 import Const		( Con(..), DataCon )
-import DataCon		( splitProductType_maybe )
+import DataCon		( splitProductType_maybe, isExistentialDataCon, dataConArgTys )
 import Demand		( Demand(..) )
 import PrelInfo		( realWorldPrimId, aBSENT_ERROR_ID )
 import TysPrim		( realWorldStatePrimTy )
@@ -30,8 +30,7 @@ import Type		( isUnLiftedType, mkTyVarTys, mkTyVarTy, mkFunTys,
 			  mkTyConApp, splitNewType_maybe,
 			  Type
 			)
-import TyCon            ( isNewTyCon,
-                          TyCon )
+import TyCon            ( isNewTyCon, isProductTyCon, TyCon )
 import BasicTypes	( NewOrData(..) )
 import Var              ( TyVar )
 import UniqSupply	( returnUs, thenUs, getUniqueUs, getUniquesUs, 
@@ -264,34 +263,36 @@ mkWrapper fun_ty arity demands cpr_info
 @mkWwBodies@ is called when doing the worker/wrapper split inside a module.
 
 \begin{code}
-mkWwBodies :: [TyVar] -> [Id] -> Type		-- Original fn args and body type
+mkWwBodies :: [TyVar] -> [Id]			-- Original fn args 
+	   -> Type				-- Type of result of original function
 	   -> [Demand]				-- Strictness info for original fn; corresp 1-1 with args
 	   -> CprInfo                           -- Result of CPR analysis 
 	   -> UniqSM (Id -> CoreExpr,		-- Wrapper body, lacking only the worker Id
 		      CoreExpr -> CoreExpr,	-- Worker body, lacking the original function body
 		      [Demand])			-- Strictness info for worker
 
-mkWwBodies tyvars wrap_args body_ty demands cpr_info
+mkWwBodies tyvars wrap_args res_ty demands cpr_info
   = let
         -- demands may be longer than number of args.  If we aren't doing w/w
         -- for strictness then demands is an infinite list of 'lazy' args.
 	wrap_args_w_demands = zipWith setIdDemandInfo wrap_args demands
-	(wrap_fn_coerce, work_fn_coerce) = mkWWcoerce body_ty
+	
     in
-    mkWWstr body_ty wrap_args_w_demands	`thenUs` \ (work_args_w_demands, wrap_fn_str, work_fn_str) ->
-
-    mkWWcpr body_ty cpr_info            `thenUs` \ (wrap_fn_cpr, work_fn_cpr) ->
+    mkWWstr wrap_args_w_demands			`thenUs` \ (wrap_fn_str,    work_fn_str,    work_arg_dmds) ->
+    mkWWcoerce res_ty				`thenUs` \ (wrap_fn_coerce, work_fn_coerce, coerce_res_ty) ->
+    mkWWcpr coerce_res_ty cpr_info      	`thenUs` \ (wrap_fn_cpr,    work_fn_cpr,    cpr_res_ty) ->
+    mkWWfixup cpr_res_ty (null work_arg_dmds)	`thenUs` \ (wrap_fn_fixup,  work_fn_fixup) ->
 
     returnUs (\ work_id -> Note InlineMe $
 			   mkLams tyvars $ mkLams wrap_args_w_demands $
-			   (wrap_fn_coerce . wrap_fn_str . wrap_fn_cpr) $
-			   mkVarApps (Var work_id) (tyvars ++ work_args_w_demands),
+			   (wrap_fn_coerce . wrap_fn_cpr . wrap_fn_str . wrap_fn_fixup) $
+			   mkVarApps (Var work_id) tyvars,
 
-	      \ work_body  -> mkLams tyvars $ mkLams work_args_w_demands $
-			      (work_fn_coerce . work_fn_str . work_fn_cpr) 
+	      \ work_body  -> mkLams tyvars $ 
+			      (work_fn_fixup . work_fn_str . work_fn_cpr . work_fn_coerce) 
 			      work_body,
 
-	      map getIdDemandInfo work_args_w_demands)
+	      work_arg_dmds)
 \end{code}
 
 
@@ -313,36 +314,25 @@ where R' is the representation type for R.
 \begin{code}
 mkWWcoerce body_ty 
   = case splitNewType_maybe body_ty of
-	Nothing     -> (id, id)
-	Just rep_ty -> (mkNote (Coerce body_ty rep_ty),
-		        mkNote (Coerce rep_ty body_ty))
+
+	Nothing     -> returnUs (id, id, body_ty)
+
+	Just rep_ty -> returnUs (mkNote (Coerce body_ty rep_ty),
+			         mkNote (Coerce rep_ty body_ty),
+				 rep_ty)
 \end{code}    
 
 
 
 %************************************************************************
 %*									*
-\subsection{Strictness stuff}
+\subsection{Fixup stuff}
 %*									*
 %************************************************************************
 
-
 \begin{code}
-mkWWstr :: Type					-- Body type
-        -> [Id]					-- Wrapper args; have their demand info on them
-        -> UniqSM ([Id],			-- Worker args; have their demand info on them
-
-		   CoreExpr -> CoreExpr,	-- Wrapper body, lacking the inner call to the worker
-						-- and without its lambdas 
-						-- At the call site, the worker args are bound
-				
-		   CoreExpr -> CoreExpr)	-- Worker body, lacking the original body of the function,
-						-- and without its lambdas
-
-mkWWstr body_ty wrap_args
-  = mk_ww wrap_args		`thenUs` \ (work_args, wrap_fn, work_fn) ->
-
-    if null work_args && isUnLiftedType body_ty then
+mkWWfixup res_ty no_worker_args
+  | no_worker_args && 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:
@@ -351,31 +341,54 @@ mkWWstr body_ty wrap_args
 	-- 	fw = /\abc. \v. body
 	--
 	-- We use the state-token type which generates no code
-	getUniqueUs 		`thenUs` \ void_arg_uniq ->
-	let
+  = getUniqueUs 		`thenUs` \ void_arg_uniq ->
+    let
 	    void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy
-	in
-	returnUs ([void_arg],
-		  wrap_fn . Let (NonRec void_arg (Var realWorldPrimId)),
-		  work_fn)
-    else
-	returnUs (work_args, wrap_fn, work_fn)
-    
+    in
+    returnUs (\ call_to_worker -> App call_to_worker (Var void_arg),
+	      \ worker_body    -> Lam void_arg worker_body)
+
+  | otherwise
+  = returnUs (id, id)
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Strictness stuff}
+%*									*
+%************************************************************************
+
+\begin{code}
+mkWWstr :: [Id]					-- Wrapper args; have their demand info on them
+        -> UniqSM (CoreExpr -> CoreExpr,	-- Wrapper body, lacking the worker call
+						-- and without its lambdas 
+						-- This fn adds the unboxing, and makes the
+						-- call passing the unboxed things
+				
+		   CoreExpr -> CoreExpr,	-- Worker body, lacking the original body of the function,
+						-- but *with* lambdas
+		   [Demand])			-- Worker arg demands
 
+mkWWstr wrap_args
+  = mk_ww_str wrap_args		`thenUs` \ (work_args_w_demands, wrap_fn, work_fn) ->
+    returnUs ( \ wrapper_body -> wrap_fn (mkVarApps wrapper_body work_args_w_demands),
+	       \ worker_body  -> mkLams work_args_w_demands (work_fn worker_body),
+	       map getIdDemandInfo work_args_w_demands)
 
 	-- Empty case
-mk_ww []
+mk_ww_str []
   = returnUs ([],
 	      \ wrapper_body -> wrapper_body,
 	      \ worker_body  -> worker_body)
 
 
-mk_ww (arg : ds)
+mk_ww_str (arg : ds)
   = case getIdDemandInfo arg of
 
 	-- Absent case
       WwLazy True ->
-	mk_ww ds 		`thenUs` \ (worker_args, wrap_fn, work_fn) ->
+	mk_ww_str ds 		`thenUs` \ (worker_args, wrap_fn, work_fn) ->
 	returnUs (worker_args, wrap_fn, mk_absent_let arg . work_fn)
 
 	-- Unpack case
@@ -383,18 +396,18 @@ mk_ww (arg : ds)
 	getUniquesUs (length inst_con_arg_tys)		`thenUs` \ uniqs ->
 	let
 	  unpk_args	 = zipWith mk_ww_local uniqs inst_con_arg_tys
-	  unpk_args_w_ds = zipWithEqual "mk_ww" setIdDemandInfo unpk_args cs
+	  unpk_args_w_ds = zipWithEqual "mk_ww_str" setIdDemandInfo unpk_args cs
 	in
-	mk_ww (unpk_args_w_ds ++ ds)		`thenUs` \ (worker_args, wrap_fn, work_fn) ->
+	mk_ww_str (unpk_args_w_ds ++ ds)		`thenUs` \ (worker_args, wrap_fn, work_fn) ->
 	returnUs (worker_args,
 	          mk_unpk_case new_or_data arg unpk_args data_con arg_tycon . wrap_fn,
 		  work_fn . mk_pk_let new_or_data arg data_con tycon_arg_tys unpk_args)
 	where
-	  (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_ww" (idType arg)
+	  (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_ww_str" (idType arg)
 
 	-- Other cases
       other_demand ->
-	mk_ww ds		`thenUs` \ (worker_args, wrap_fn, work_fn) ->
+	mk_ww_str ds		`thenUs` \ (worker_args, wrap_fn, work_fn) ->
 	returnUs (arg : worker_args, wrap_fn, work_fn)
 \end{code}
 
@@ -419,18 +432,19 @@ left-to-right traversal of the result structure.
 mkWWcpr :: Type                              -- function body type
         -> CprInfo                           -- CPR analysis results
         -> UniqSM (CoreExpr -> CoreExpr,             -- New wrapper 
-                   CoreExpr -> CoreExpr)	     -- New worker
+                   CoreExpr -> CoreExpr,	     -- New worker
+		   Type)			-- Type of worker's body 
 
 mkWWcpr body_ty NoCPRInfo 
-    = returnUs (id, id)      -- Must be just the strictness transf.
+    = returnUs (id, id, body_ty)      -- Must be just the strictness transf.
 mkWWcpr body_ty (CPRInfo cpr_args)
     = getUniqueUs 		`thenUs` \ body_arg_uniq ->
       let
         body_var = mk_ww_local body_arg_uniq body_ty
       in
       cpr_reconstruct body_ty cpr_info'                   `thenUs` \reconst_fn ->
-      cpr_flatten body_ty cpr_info'                       `thenUs` \flatten_fn ->
-      returnUs (reconst_fn, flatten_fn)
+      cpr_flatten body_ty cpr_info'                       `thenUs` \(flatten_fn, res_ty) ->
+      returnUs (reconst_fn, flatten_fn, res_ty)
     where
 	    -- We only make use of the outer level of CprInfo,  otherwise we
 	    -- may lose laziness.  :-(  Hopefully,  we will find a use for the
@@ -445,11 +459,14 @@ from the CPR analysis and flattens the constructed product components.
 These are returned in an unboxed tuple.
 
 \begin{code}
-cpr_flatten :: Type -> CprInfo -> UniqSM (CoreExpr -> CoreExpr)
+cpr_flatten :: Type -> CprInfo -> UniqSM (CoreExpr -> CoreExpr, Type)
 cpr_flatten ty cpr_info
     = mk_cpr_case (ty, cpr_info)       `thenUs` \(res_id, tup_ids, flatten_exp) ->
-      returnUs (\body -> Case body res_id
-                         [(DEFAULT, [], flatten_exp (fst $ mk_unboxed_tuple tup_ids))])
+      let
+	(unbx_tuple, unbx_tuple_ty) = mk_unboxed_tuple tup_ids
+      in
+      returnUs (\body -> Case body res_id [(DEFAULT, [], flatten_exp unbx_tuple)],
+		unbx_tuple_ty)
 
 
 
@@ -527,6 +544,8 @@ mk_cpr_let (ty, NoCPRInfo)
       returnUs (id_id, [id_id], id)
 
 mk_cpr_let (ty, cpr_info@(CPRInfo ci_args))
+
+{- Should not be needed now:  mkWWfixup does this job
     | isNewTyCon tycon   -- a new type: must coerce the argument to this type
     = ASSERT ( null $ tail inst_con_arg_tys )
       mk_cpr_let (target_of_from_type, cpr_info) 
@@ -539,6 +558,7 @@ mk_cpr_let (ty, cpr_info@(CPRInfo ci_args))
 
     | otherwise     -- a data type
                     -- reconstruct components then apply data con
+-}
     = mapUs mk_cpr_let (zip inst_con_arg_tys ci_args) 
                                  `thenUs`  \sub_builds ->
       getUniqueUs                `thenUs`  \id_uniq   ->
@@ -557,9 +577,34 @@ mk_cpr_let (ty, cpr_info@(CPRInfo ci_args))
 
 
 splitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type])
-splitProductType fname ty = case splitProductType_maybe ty of
-				Just stuff -> stuff
-				Nothing    -> pprPanic (fname ++ ": not a product") (ppr ty)
+  -- For a tiresome reason, the type might not look like a product type
+  -- This happens when compiling the compiler!  The module Name
+  -- imports {-# SOURCE #-} TyCon and Id
+  -- 	data Name = Name NameSort Unique OccName Provenance
+  --    data NameSort = WiredInId Module Id | ...
+  -- So Name does not look recursive (because Id is imported via a hi-boot file,
+  -- which says nothing about Id's rep) but actually it is, because Ids have Names.
+  -- Modules that *import* Name have a more complete view, see that Name is recursive,
+  -- and therefore that it isn't a ProductType.  This conflicts with the CPR info
+  -- in exports from Name that say "do CPR".
+  --
+  -- Arguably we should regard Name as a product anyway because it isn't recursive
+  -- via products all the way... but we don't have that info to hand, and even if
+  -- we did this case might *still* arise.
+
+  -- 
+  -- So we hack our way out for now, by trusting the pragma that said "do CPR"
+  -- that means we can't use splitProductType_maybe
+
+splitProductType fname ty
+   = case splitAlgTyConApp_maybe ty of
+	Just (tycon, tycon_args, (con:other_cons))
+	  | null other_cons && not (isExistentialDataCon con)
+	  -> WARN( not (isProductTyCon tycon),
+		   text "splitProductType hack: I happened!" <+> ppr ty )
+	     (tycon, tycon_args, con, dataConArgTys con tycon_args)
+	     
+	Nothing -> pprPanic (fname ++ ": not a product") (ppr ty)
 \end{code}
 
 

ghc/compiler/types/Type.lhs

@@ -597,6 +597,7 @@ repType other_ty	  		  = other_ty
 
 splitNewType_maybe :: Type -> Maybe Type
 -- Find the representation of a newtype, if it is one
+-- Looks through multiple levels of newtype
 splitNewType_maybe (NoteTy _ ty) 		     = splitNewType_maybe ty
 splitNewType_maybe (TyConApp tc tys) | isNewTyCon tc = case splitNewType_maybe rep_ty of
 								Just rep_ty' -> Just rep_ty'