[project @ 1996-07-25 20:43:49 by partain]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreLift.lhs

diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs
index 71383a5..59c655a 100644 (file)
--- a/ghc/compiler/coreSyn/CoreLift.lhs
+++ b/ghc/compiler/coreSyn/CoreLift.lhs
@@ -12,23 +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 Name            ( isLocallyDefined, getSrcLoc )
-import PrelInfo                ( liftDataCon, mkLiftTy, statePrimTyCon )
 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 )
 
@@ -129,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 ->
@@ -257,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 ???
 
@@ -308,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)