From bfb876458300aa8c691c3160136136f3d4ee3375 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 6 Dec 2004 10:58:06 +0000
Subject: [PATCH] [project @ 2004-12-06 10:58:06 by simonpj]
 --------------------- 	Bug in specialisation 
 ---------------------

Laszlo managed to get a function like this:

	foo :: Enum a => (# a, Int #)

The specialiser specialised it, resulting in an unboxed tuple
binding, which Lint objected to.

This commit adds a dummy argument to the specialised function,
very like the case for strictness analysis.  For example, at
type Char we'd get

	foo_char :: State# RealWorld -> (# Char, Int #)
 	foo_char = \_ -> ...

We use a State# type because it generates no argument-passing code
at runtime.  (We should really have some other void type for this
purpose, because State# is misleading, but this way avoids extra
types.)
---
 ghc/compiler/specialise/Specialise.lhs |   16 +++++++++++-----
 1 file changed, 11 insertions(+), 5 deletions(-)

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 752e682..1813d7e 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -12,7 +12,7 @@ import CmdLineOpts	( DynFlags, DynFlag(..) )
 import Id		( Id, idName, idType, mkUserLocal ) 
 import TcType		( Type, mkTyVarTy, tcSplitSigmaTy, 
 			  tyVarsOfTypes, tyVarsOfTheta, isClassPred,
-			  mkForAllTys, tcCmpType
+			  tcCmpType, isUnLiftedType
 			)
 import Subst		( Subst, SubstResult(..), mkSubst, mkSubst, extendTvSubstList, 
 			  simplBndr, simplBndrs, substTy,
@@ -23,7 +23,7 @@ import Var		( zapSpecPragmaId )
 import VarSet
 import VarEnv
 import CoreSyn
-import CoreUtils	( applyTypeToArgs )
+import CoreUtils	( applyTypeToArgs, mkPiTypes )
 import CoreFVs		( exprFreeVars, exprsFreeVars )
 import CoreTidy		( pprTidyIdRules )
 import CoreLint		( showPass, endPass )
@@ -34,6 +34,7 @@ import UniqSupply	( UniqSupply,
 			  getUs, mapUs
 			)
 import Name		( nameOccName, mkSpecOcc, getSrcLoc )
+import MkId		( voidArgId, realWorldPrimId )
 import FiniteMap
 import Maybes		( catMaybes, maybeToBool )
 import ErrUtils		( dumpIfSet_dyn )
@@ -879,10 +880,15 @@ specDefn subst calls (fn, rhs)
 	   inst_args = ty_args ++ map Var rhs_dicts'
 
 		-- Figure out the type of the specialised function
-	   spec_id_ty = mkForAllTys poly_tyvars (applyTypeToArgs rhs fn_type inst_args)
+	   body_ty = applyTypeToArgs rhs fn_type inst_args
+	   (lam_args, app_args) 		-- Add a dummy argument if body_ty is unlifted
+		| isUnLiftedType body_ty	-- C.f. WwLib.mkWorkerArgs
+		= (poly_tyvars ++ [voidArgId], poly_tyvars ++ [realWorldPrimId])
+		| otherwise = (poly_tyvars, poly_tyvars)
+	   spec_id_ty = mkPiTypes lam_args body_ty
 	in
 	newIdSM fn spec_id_ty				`thenSM` \ spec_f ->
-	specExpr rhs_subst' (mkLams poly_tyvars body)	`thenSM` \ (spec_rhs, rhs_uds) ->	
+	specExpr rhs_subst' (mkLams lam_args body)	`thenSM` \ (spec_rhs, rhs_uds) ->	
 	let
 		-- The rule to put in the function's specialisation is:
 		--	forall b,d, d1',d2'.  f t1 b t3 d d1' d2' = f1 b d  
@@ -890,7 +896,7 @@ specDefn subst calls (fn, rhs)
 				AlwaysActive
 			        (poly_tyvars ++ rhs_dicts')
 				inst_args 
-				(mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
+				(mkVarApps (Var spec_f) app_args)
 
 		-- Add the { d1' = dx1; d2' = dx2 } usage stuff
 	   final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds)
-- 
1.7.10.4