X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBinds.lhs;h=764e44b470f53da5fdae3b20ff5b0833586ec337;hb=a200038f469418fef77d863dc3d1cd0125ec1e82;hp=57bbd02c7da785311e9ee5592c2fa8898e9daea6;hpb=15b860cb80dcc58de964da44ebaf366f66fc7d27;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 57bbd02..764e44b 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -26,15 +26,17 @@ import DsUtils
 
 import HsSyn		-- lots of things
 import CoreSyn		-- lots of things
+import MkCore
 import CoreUtils
 import CoreFVs
 
-import TcHsSyn		( mkArbitraryType )	-- Mis-placed?
+import TcHsSyn	( mkArbitraryType )	-- Mis-placed?
 import TcType
 import OccurAnal
 import CostCentre
 import Module
 import Id
+import Name	( localiseName )
 import Var	( TyVar )
 import VarSet
 import Rules
@@ -332,6 +334,9 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
 	; spec_name <- newLocalName poly_name
 	; ds_spec_expr  <- dsExpr spec_expr
 	; let (bndrs, body) = collectBinders (occurAnalyseExpr ds_spec_expr)
+	      -- ds_spec_expr may look like
+	      --     /\a. f a Int dOrdInt
+	      -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
 		-- The occurrence-analysis does two things
 		-- (a) identifies unused binders: Note [Unused spec binders]
 		-- (b) sorts dict bindings into NonRecs 
@@ -357,7 +362,9 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
 		  spec_rhs    = Let (NonRec local_poly poly_f_body) ds_spec_expr
 		  poly_f_body = mkLams (tvs ++ dicts) f_body
 			   	
-		  extra_dict_bndrs = filter isDictId (varSetElems (exprFreeVars ds_spec_expr))
+		  extra_dict_bndrs = [localise d 
+		  		     | d <- varSetElems (exprFreeVars ds_spec_expr)
+		  		     , isDictId d]
 			-- Note [Const rule dicts]
 
 		  rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
@@ -384,6 +391,9 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
     decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
 		    2 (ppr spec_expr)
 
+    localise d = mkLocalId (localiseName (idName d)) (idType d)
+    	     -- See Note [Constant rule dicts]
+
 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type)
 -- If any of the tyvars is missing from any of the lists in 
 -- the second arg, return a binding in the result
@@ -441,6 +451,9 @@ And from that we want the rule
 	RULE forall dInt. f Int dInt = f_spec
 	f_spec = let f = <rhs> in f Int dInt
 
+But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
+Name, and you can't bind them in a lambda or forall without getting things
+confused. Hence the use of 'localise' to make it Internal.
 
 
 %************************************************************************
@@ -574,8 +587,11 @@ dsCoercion (WpLam id)        thing_inside = do { expr <- thing_inside
 					       ; return (Lam id expr) }
 dsCoercion (WpTyLam tv)      thing_inside = do { expr <- thing_inside
 					       ; return (Lam tv expr) }
-dsCoercion (WpApp id)        thing_inside = do { expr <- thing_inside
-					       ; return (App expr (Var id)) }
+dsCoercion (WpApp v)         thing_inside   
+	   | isTyVar v	    		  = do { expr <- thing_inside
+		{- Probably a coercion var -}  ; return (App expr (Type (mkTyVarTy v))) }
+	   | otherwise	    		  = do { expr <- thing_inside
+		{- An Id -}		       ; return (App expr (Var v)) }
 dsCoercion (WpTyApp ty)      thing_inside = do { expr <- thing_inside
 					       ; return (App expr (Type ty)) }
 dsCoercion WpInline 	     thing_inside = do { expr <- thing_inside