X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLift.lhs;h=59c655aca600404b7085e4d1323c204f1d45e744;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hp=ecae1733c40a356f334a0c12c794c1d140dcc776;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs
index ecae173..59c655a 100644
--- a/ghc/compiler/coreSyn/CoreLift.lhs
+++ b/ghc/compiler/coreSyn/CoreLift.lhs
@@ -12,22 +12,23 @@ module CoreLift (
 	mkLiftedId,
 	liftExpr,
 	bindUnlift,
-	applyBindUnlifts,
-	isUnboxedButNotState
+	applyBindUnlifts
 
     ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
 import CoreSyn
 import CoreUtils	( coreExprType )
 import Id		( idType, mkSysLocal,
-			  nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..),
+			  nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv),
 			  GenId{-instances-}
 			)
-import PrelInfo		( liftDataCon, mkLiftTy, statePrimTyCon )
+import Name		( isLocallyDefined, getSrcLoc )
 import TyCon		( isBoxedTyCon, TyCon{-instance-} )
-import Type		( maybeAppDataTyCon, eqTy )
+import Type		( maybeAppDataTyConExpandingDicts, eqTy )
+import TysPrim		( statePrimTyCon )
+import TysWiredIn	( liftDataCon, mkLiftTy )
 import UniqSupply	( getUnique, getUniques, splitUniqSupply, UniqSupply )
 import Util		( zipEqual, zipWithEqual, assertPanic, panic )
 
@@ -128,6 +129,10 @@ liftCoreExpr (SCC label expr)
   = liftCoreExpr expr		`thenL` \ expr ->
     returnL (SCC label expr)
 
+liftCoreExpr (Coerce coerce ty expr)
+  = liftCoreExpr expr		`thenL` \ expr ->
+    returnL (Coerce coerce ty expr) -- ToDo:right?:Coerce
+
 liftCoreExpr (Let (NonRec binder rhs) body) -- special case: no lifting
   = liftCoreExpr rhs	`thenL` \ rhs ->
     liftCoreExpr body	`thenL` \ body ->
@@ -256,7 +261,7 @@ liftBinders top_lev bind liftM idenv s0
     (s1, s2)   = splitUniqSupply s0
     lift_ids   = [ id | id <- bindersOf bind, isUnboxedButNotState (idType id) ]
     lift_uniqs = getUniques (length lift_ids) s1
-    lift_map   = zipEqual lift_ids (zipWithEqual mkLiftedId lift_ids lift_uniqs)
+    lift_map   = zipEqual "liftBinders" lift_ids (zipWithEqual "liftBinders" mkLiftedId lift_ids lift_uniqs)
 
     -- ToDo: Give warning for recursive bindings involving unboxed values ???
 
@@ -274,7 +279,7 @@ mkLiftedId id u
   = ASSERT (isUnboxedButNotState unlifted_ty)
     (lifted_id, unlifted_id)
   where
-    id_name     = getOccurrenceName id
+    id_name     = panic "CoreLift.mkLiftedId:id_name" --LATER: getOccName id
     lifted_id   = updateIdType id lifted_ty
     unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
 
@@ -307,7 +312,7 @@ applyBindUnlifts []     expr = expr
 applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
 
 isUnboxedButNotState ty
-  = case (maybeAppDataTyCon ty) of
+  = case (maybeAppDataTyConExpandingDicts ty) of
       Nothing -> False
       Just (tycon, _, _) ->
 	not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)