From 7f86e9a9bb1375f06a8784c612a2808c58e44729 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Thu, 11 Feb 1999 16:33:44 +0000
Subject: [PATCH] [project @ 1999-02-11 16:33:44 by simonpj] Fix yet another
 specialiser dict-floating bug; showed up in
 nofib/spectral/typech98

---
 ghc/compiler/specialise/Specialise.lhs |   45 ++++++++++++++++++++++----------
 1 file changed, 31 insertions(+), 14 deletions(-)

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 081393a..080fd0e 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -826,13 +826,22 @@ specDefn calls (fn, rhs)
         let
 	   (maybe_spec_tyvars, spec_tys) = unzip stuff
            spec_tyvars = catMaybes maybe_spec_tyvars
-	   spec_rhs    = mkLams spec_tyvars $
-                         mkApps rhs (map Type spec_tys ++ call_ds)
-  	   spec_id_ty  = mkForAllTys spec_tyvars (substTy ty_env tau)
-	   ty_env      = zipVarEnv tyvars spec_tys
+  	   spec_id_ty  = mkForAllTys spec_tyvars 
+				     (substTy (zipVarEnv tyvars spec_tys) tau)
+		-- NB When substituting in tau we need a ty_env mentioning tyvars
+		-- but when substituting in UDs we need a ty_evn mentioning rhs_tyvars
+	   ud_ty_env   = zipVarEnv rhs_tyvars spec_tys
+	   ud_dict_env = zipVarEnv rhs_dicts (map Done call_ds)
+
+		-- Only the overloaded tyvars should be free in the uds
+	   ty_env   = mkVarEnv [ (rhs_tyvar, ty) 
+			       | (rhs_tyvar, Just ty) <- zipEqual "specUDs1" rhs_tyvars call_ts
+			       ]
+
 	in
 
-	newIdSM fn spec_id_ty		`thenSM` \ spec_f ->
+		-- Specialise the UDs from f's RHS
+        specUDs ud_ty_env ud_dict_env bound_uds			`thenSM` \ spec_uds ->
 
 
 		-- Construct the stuff for f's spec env
@@ -844,6 +853,7 @@ specDefn calls (fn, rhs)
 		--
 		-- In fact we use the standard template locals, so that the
 		-- they don't need to be "tidied" before putting in interface files
+	newIdSM fn spec_id_ty		`thenSM` \ spec_f ->
 	let
 	   arg_ds	 = mkTemplateLocals (map coreExprType call_ds)
 	   spec_env_rhs  = mkLams arg_ds $
@@ -852,18 +862,25 @@ specDefn calls (fn, rhs)
            spec_env_info = (spec_tyvars, spec_tys, spec_env_rhs)
         in
 
-		-- Specialise the UDs from f's RHS
+		-- Finally construct f's RHS
+		-- Annoyingly, the specialised UDs may mention some of the *un* specialised
+		-- type variables.  Here's a case that came up in nofib/spectral/typech98:
+		--	f = /\m a -> \d:Monad m -> let d':Monad (T m a) = ...a... in ...
+		-- When we try to make a specialised verison of f, from a call pattern
+		--	(f Maybe ?)
+		-- where ? is the Nothing for an unspecialised position, we must get
+		--	spec_f = /\ a -> let d':Monad (T Maybe a) = ...a... in ....
+		-- If we don't do the splitUDs below, the d' binding floats out too far.
+		-- Sigh. What a mess.
 	let
-		-- Only the overloaded tyvars should be free in the uds
-	   ty_env   = mkVarEnv [ (rhs_tyvar, ty) 
-			       | (rhs_tyvar, Just ty) <- zipEqual "specUDs1" rhs_tyvars call_ts
-			       ]
-	   dict_env = zipVarEnv rhs_dicts (map Done call_ds)
-	in
-        specUDs ty_env dict_env bound_uds			`thenSM` \ spec_uds ->
+	   (float_uds, (dict_binds,_)) = splitUDs spec_tyvars spec_uds
 
+	   spec_rhs    = mkLams spec_tyvars $
+			 mkDictLets dict_binds $
+                         mkApps rhs (map Type spec_tys ++ call_ds)
+	in
         returnSM ((spec_f, spec_rhs),
-	          spec_uds,
+	          float_uds,
 		  spec_env_info
 	)
 \end{code}
-- 
1.7.10.4