X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPragmas.lhs;h=065215247a2c59af4b10b8e8ee0e04e341e92910;hp=59153c52f30c43fa2b22f036e5776ace0d714f18;hb=12899612693163154531da3285ec99c1c8ca2226;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff

diff --git a/ghc/compiler/typecheck/TcPragmas.lhs b/ghc/compiler/typecheck/TcPragmas.lhs
index 59153c5..0652152 100644
--- a/ghc/compiler/typecheck/TcPragmas.lhs
+++ b/ghc/compiler/typecheck/TcPragmas.lhs
@@ -13,13 +13,11 @@ module TcPragmas (
 	tcGenPragmas
     ) where
 
-import TcMonad		-- typechecking monadic machinery
+import TcMonad		hiding ( rnMtoTcM )
 import HsSyn		-- the stuff being typechecked
 
-import PrelInfo		( PrimOp(..)	-- to see CCallOp
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-			)
+--import PrelInfo		( PrimOp(..)	-- to see CCallOp
+--			)
 import Type
 import CmdLineOpts
 import CostCentre
@@ -28,7 +26,7 @@ import HsPragmas	-- ****** NEED TO SEE CONSTRUCTORS ******
 import Id
 import IdInfo
 --import WwLib		( mkWwBodies )
-import Maybes		( assocMaybe, catMaybes, Maybe(..) )
+import Maybes		( assocMaybe, catMaybes )
 --import CoreLint		( lintUnfolding )
 import TcMonoType	( tcMonoType, tcPolyType )
 import Util
@@ -181,7 +179,7 @@ tc_strictness
 	-> Maybe Type
 	-> Id		-- final Id (do not *touch*)
 	-> ImpStrictness Name
-	-> Baby_TcM (StrictnessInfo, UnfoldingDetails)
+	-> Baby_TcM (StrictnessInfo, Unfolding)
 
 tc_strictness e ty_maybe rec_final_id info
   = getSwitchCheckerB_Tc    `thenB_Tc` \ sw_chkr ->
@@ -235,7 +233,7 @@ do_strictness e (Just wrapper_ty) rec_final_id
   = -- Strictness info suggests a worker.  Things could still
     -- go wrong if there's an abstract type involved, mind you.
     let
-	(tv_tmpls, arg_tys, ret_ty) = splitTypeWithDictsAsArgs wrapper_ty
+	(tv_tmpls, arg_tys, ret_ty) = splitFunTyExpandingDicts wrapper_ty
 	n_wrapper_args		    = length wrap_arg_info
 		-- Don't have more args than this, else you risk
 		-- losing laziness!!
@@ -253,7 +251,7 @@ do_strictness e (Just wrapper_ty) rec_final_id
 	inst_ret_ty  = glueTyArgs dropped_inst_arg_tys
 				  (instantiateTy inst_env ret_ty)
 
-	args         = zipWithEqual mk_arg arg_uniqs	undropped_inst_arg_tys
+	args           = zipWithEqual "do_strictness" mk_arg arg_uniqs undropped_inst_arg_tys
 	mk_arg uniq ty = mkSysLocal SLIT("wrap") uniq ty mkUnknownSrcLoc
 	-- ASSERT: length args = n_wrapper_args
     in
@@ -361,7 +359,7 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
 	-- NB: We cant check the lint result and return noInfo_UF if
 	--     lintUnfolding failed as this is too strict
 	--     Instead getInfo_UF tests for BadUnfolding and converts
-	--     to NoUnfoldingDetails when the unfolding is accessed
+	--     to NoUnfolding when the unfolding is accessed
 
 	maybe_lint_expr = lintUnfolding locn core_expr
 
@@ -485,7 +483,7 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
 	in
 	mapB_Tc (tc_uf_core new_lve tve) rhss `thenB_Tc` \ new_rhss ->
 	tc_uf_core new_lve tve         body `thenB_Tc` \ new_body ->
-	returnB_Tc (Let (Rec (new_binders `zip` new_rhss)) new_body)
+	returnB_Tc (Let (Rec (zipEqual "tc_uf_core" new_binders new_rhss)) new_body)
 
     tc_uf_core lve tve (UfSCC uf_cc body)
       = tc_uf_cc   uf_cc	    `thenB_Tc` \ new_cc ->
@@ -557,21 +555,21 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
 	    clas       = lookupCE rec_ce c
 	    super_clas = lookupCE rec_ce sc
 	in
-	returnB_Tc (getSuperDictSelId clas super_clas)
+	returnB_Tc (classSuperDictSelId clas super_clas)
 
     tc_uf_Id lve (ClassOpUfId c op_name)
       = let
 	    clas = lookupCE rec_ce c
 	    op	 = lookup_class_op clas op_name
 	in
-	returnB_Tc (getClassOpId clas op)
+	returnB_Tc (classOpId clas op)
 
     tc_uf_Id lve (DefaultMethodUfId c op_name)
       = let
 	    clas = lookupCE rec_ce c
 	    op	 = lookup_class_op clas op_name
 	in
-	returnB_Tc (getDefaultMethodId clas op)
+	returnB_Tc (classDefaultMethodId clas op)
 
     tc_uf_Id lve uf_id@(DictFunUfId c ty)
       = tc_uf_type nullTVE ty	`thenB_Tc` \ new_ty ->
@@ -624,7 +622,7 @@ tc_unfolding e (ImpUnfolding guidance uf_core)
 
     ---------------
     lookup_class_op clas (ClassOpName _ _ _ tag)
-      = getClassOps clas !! (tag - 1)
+      = classOps clas !! (tag - 1)
 
     ---------------------------------------------------------------------
     tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM Type