X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=7d95266da4b186ad583f9fc138cc00fc3ee4e975;hb=ab5b8aa357c685a7c702262903bce04c66f79156;hp=fd4e3e205c16630f263953af2a175288e64a87ea;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index fd4e3e2..7d95266 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -18,7 +18,7 @@ module MkId (
 
 	mkDataConIds,
 	mkRecordSelId, 
-	mkPrimOpId, mkFCallId,
+	mkPrimOpId, mkFCallId, mkTickBoxOpId, 
 
 	mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
         mkUnpackCase, mkProductBox,
@@ -72,6 +72,7 @@ import Util
 import Outputable
 import FastString
 import ListSetOps
+import Module
 \end{code}		
 
 %************************************************************************
@@ -246,6 +247,7 @@ mkDataConIds wrap_name wkr_name data_con
 							-- even if arity = 0
 
     wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
+	--	Note [Data-con worker strictness]
 	-- Notice that we do *not* say the worker is strict
 	-- even if the data constructor is declared strict
 	--	e.g. 	data T = MkT !(Int,Int)
@@ -592,14 +594,14 @@ mkRecordSelId tycon field_label
 	--		T1 b' (c : [b]=[b']) (x:Maybe b') 
 	--			-> x `cast` Maybe (sym (right c))
 
-        Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
-        (co_fn, res_ty) = refineType refinement (idType the_arg_id)
+
 		-- Generate the refinement for b'=b, 
 		-- and apply to (Maybe b'), to get (Maybe b)
-
-        rhs = case co_fn of
-		WpCo co -> Cast (Var the_arg_id) co
-		id_co	    -> ASSERT(isIdHsWrapper id_co) Var the_arg_id
+        Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
+	the_arg_id_ty = idType the_arg_id
+        (rhs, res_ty) = case refineType refinement the_arg_id_ty of
+			  Just (co, res_ty) -> (Cast (Var the_arg_id) co, res_ty)
+			  Nothing	    -> (Var the_arg_id, the_arg_id_ty)
 
 	field_vs    = filter (not . isPredTy . idType) arg_vs 
     	the_arg_id  = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label
@@ -902,6 +904,18 @@ mkFCallId uniq fcall ty
     (arg_tys, _) = tcSplitFunTys tau
     arity	 = length arg_tys
     strict_sig   = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
+
+mkTickBoxOpId :: Unique 
+	      -> Module
+	      -> TickBoxId
+	      -> Id
+mkTickBoxOpId uniq mod ix =  mkGlobalId (TickBoxOpId tickbox) name ty info    
+  where
+    tickbox = TickBox mod ix
+    occ_str = showSDoc (braces (ppr tickbox))
+    name    = mkTickBoxOpName uniq occ_str
+    info    = noCafIdInfo
+    ty      = realWorldStatePrimTy 
 \end{code}
 
 
@@ -1036,8 +1050,7 @@ unsafeCoerceId
 		      (mkFunTy openAlphaTy openBetaTy)
     [x] = mkTemplateLocals [openAlphaTy]
     rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
---       Note (Coerce openBetaTy openAlphaTy) (Var x)
-         Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy)
+          Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy)
 
 -- nullAddr# :: Addr#
 -- The reason is is here is because we don't provide