X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsBinds.lhs;h=4f2323d4edc7770538699fa7da0c9fbe14ac2da1;hb=acc784b55045fe43b2d92efc992a4b888d96c682;hp=f045619bac2cd3877f4b3a97679e94712a0efdcf;hpb=2c6d73e2ca9a545c4295c6f532cd3612e7fd3d8d;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index f045619..4f2323d 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -29,8 +29,8 @@ import CostCentre	( mkAutoCC, IsCafCC(..) )
 import Id		( idType, idName, isExportedId, isSpecPragmaId, Id )
 import NameSet
 import VarSet
-import Type		( mkTyVarTy )
-import Subst		( mkTyVarSubst, substTy )
+import TcType		( mkTyVarTy )
+import Subst		( substTyWith )
 import TysWiredIn	( voidTy )
 import Outputable
 import Maybe		( isJust )
@@ -90,12 +90,16 @@ dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest
     returnDs (sel_binds ++ rest)
 
 	-- Common special case: no type or dictionary abstraction
+	-- For the (rare) case when there are some mixed-up
+	-- dictionary bindings (for which a Rec is convenient)
+	-- we reply on the enclosing dsBind to wrap a Rec around.
 dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest
   = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
     let 
-	exports' = [(global, Var local) | (_, global, local) <- exports]
+	core_prs' = addLocalInlines exports inlines core_prs
+	exports'  = [(global, Var local) | (_, global, local) <- exports]
     in
-    returnDs (addLocalInlines exports inlines core_prs ++ exports' ++ rest)
+    returnDs (core_prs' ++ exports' ++ rest)
 
 	-- Another common case: one exported variable
 	-- Non-recursive bindings come through this way
@@ -106,22 +110,26 @@ dsMonoBinds auto_scc
     let 
 	-- Always treat the binds as recursive, because the typechecker
 	-- makes rather mixed-up dictionary bindings
-	core_binds = [Rec core_prs]
-	global'    = (global, mkInline (idName global `elemNameSet` inlines) $
+	core_bind = Rec core_prs
+
+	-- The mkInline does directly what the 
+	-- addLocalInlines do in the other cases
+	export'    = (global, mkInline (idName global `elemNameSet` inlines) $
 			      mkLams tyvars $ mkLams dicts $ 
-	                      mkDsLets core_binds (Var local))
+	                      Let core_bind (Var local))
     in
-    returnDs (global' : rest)
+    returnDs (export' : rest)
 
 dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
   = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
     let 
-	core_binds = [Rec (addLocalInlines exports inlines core_prs)]
+	-- Rec because of mixed-up dictionary bindings
+	core_bind = Rec (addLocalInlines exports inlines core_prs)
 
 	tup_expr      = mkTupleExpr locals
 	tup_ty	      = exprType tup_expr
 	poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
-		        mkDsLets core_binds tup_expr
+		        Let core_bind tup_expr
 	locals        = [local | (_, _, local) <- exports]
 	local_tys     = map idType locals
     in
@@ -132,16 +140,16 @@ dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
 	mk_bind (tyvars, global, local) n	-- locals !! n == local
 	  = 	-- Need to make fresh locals to bind in the selector, because
 		-- some of the tyvars will be bound to voidTy
-	    newSysLocalsDs (map (substTy env) local_tys) 	`thenDs` \ locals' ->
-	    newSysLocalDs  (substTy env tup_ty)			`thenDs` \ tup_id ->
+	    newSysLocalsDs (map substitute local_tys) 	`thenDs` \ locals' ->
+	    newSysLocalDs  (substitute tup_ty)		`thenDs` \ tup_id ->
 	    returnDs (global, mkLams tyvars $ mkLams dicts $
 		              mkTupleSelector locals' (locals' !! n) tup_id $
 		              mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args)
 	  where
 	    mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
 				| otherwise		  = voidTy
-	    ty_args = map mk_ty_arg all_tyvars
-	    env     = mkTyVarSubst all_tyvars ty_args
+	    ty_args    = map mk_ty_arg all_tyvars
+	    substitute = substTyWith all_tyvars ty_args
     in
     zipWithDs mk_bind exports [0..]		`thenDs` \ export_binds ->
      -- don't scc (auto-)annotate the tuple itself.