X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBinds.lhs;h=27d41476e1ce993ad58bd843ab9cd40f77f9b293;hp=85581c9aad43d5627cb7a1eebfabd490d67a5ce3;hb=d5934bbb856aa0aa620c9b2e0fa51c90a1a5a048;hpb=60e9e613cf99e45f86a84bbba5ef3cadab40b1af

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 85581c9..27d4147 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -1,7 +1,9 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[DsBinds]{Pattern-matching bindings (HsBinds and MonoBinds)}
+
+Pattern-matching bindings (HsBinds and MonoBinds)
 
 Handles @HsBinds@; those at the top level require different handling,
 in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
@@ -15,36 +17,37 @@ module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs,
 
 #include "HsVersions.h"
 
-
 import {-# SOURCE #-}	DsExpr( dsLExpr, dsExpr )
 import {-# SOURCE #-}	Match( matchWrapper )
 
 import DsMonad
-import DsGRHSs		( dsGuarded )
+import DsGRHSs
 import DsUtils
 
 import HsSyn		-- lots of things
 import CoreSyn		-- lots of things
-import CoreUtils	( exprType, mkInlineMe, mkSCC )
-
-import OccurAnal	( occurAnalyseExpr )
-import CostCentre	( mkAutoCC, IsCafCC(..) )
-import Id		( Id, DictId, idType, idName, mkLocalId, setInlinePragma )
-import Rules		( addIdSpecialisations, mkLocalRule )
-import Var		( TyVar, Var, isGlobalId, setIdNotExported )
+import CoreUtils
+
+import TcHsSyn		( mkArbitraryType )	-- Mis-placed?
+import OccurAnal
+import CostCentre
+import Module
+import Id
+import Rules
+import Var              ( TyVar, Var )
 import VarEnv
-import Type		( mkTyVarTy, substTyWith )
-import TysWiredIn	( voidTy )
-import Module		( Module )
+import Type
+import TysWiredIn
 import Outputable
-import SrcLoc		( Located(..) )
-import Maybes		( catMaybes, orElse )
-import Bag		( bagToList )
-import BasicTypes	( Activation(..), InlineSpec(..), isAlwaysActive )
-import Monad		( foldM )
-import FastString	( mkFastString )
-import List		( (\\) )
+import SrcLoc
+import Maybes
+import Bag
+import BasicTypes hiding ( TopLevel )
+import FastString
 import Util		( mapSnd )
+
+import Control.Monad
+import Data.List
 \end{code}
 
 %************************************************************************
@@ -86,9 +89,10 @@ dsHsBind auto_scc rest (VarBind var expr)
     addDictScc var core_expr	`thenDs` \ core_expr' ->
     returnDs ((var, core_expr') : rest)
 
-dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn })
+dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick })
   = matchWrapper (FunRhs (idName fun)) matches		`thenDs` \ (args, body) ->
-    dsCoercion co_fn (return (mkLams args body))	`thenDs` \ rhs ->
+    mkOptTickBox tick body 				`thenDs` \ body' ->
+    dsCoercion co_fn (return (mkLams args body'))	`thenDs` \ rhs ->
     returnDs ((fun,rhs) : rest)
 
 dsHsBind auto_scc rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
@@ -176,7 +180,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 
 	      mk_bind ((tyvars, global, local, prags), n)	-- locals !! n == local
 	        = 	-- Need to make fresh locals to bind in the selector, because
-		      	-- some of the tyvars will be bound to voidTy
+		      	-- some of the tyvars will be bound to 'Any'
 		  do { locals' <- newSysLocalsDs (map substitute local_tys)
 		     ; tup_id  <- newSysLocalDs  (substitute tup_ty)
 		     ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) 
@@ -189,7 +193,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 		     ; returnDs ((global', rhs) : spec_binds) }
 	        where
 	          mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
-	      			      | otherwise		= voidTy
+	      			      | otherwise		= mkArbitraryType all_tyvar
 	          ty_args    = map mk_ty_arg all_tyvars
 	          substitute = substTyWith all_tyvars ty_args
 
@@ -264,11 +268,11 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
 				(mkVarApps (Var spec_id) bndrs)
 	}
   where
-	-- Bind to voidTy any of all_ptvs that aren't 
+	-- Bind to Any any of all_ptvs that aren't 
 	-- relevant for this particular function 
     fix_up body | null void_tvs = body
 		| otherwise	= mkTyApps (mkLams void_tvs body) 
-					   (map (const voidTy) void_tvs)
+					   (map mkArbitraryType void_tvs)
     void_tvs = all_tvs \\ tvs
 
     msg = hang (ptext SLIT("Specialisation too complicated to desugar; ignored"))