[project @ 1998-01-08 18:03:08 by simonm]

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

diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs
index 90f7656..eb284c1 100644 (file)
--- a/ghc/compiler/coreSyn/CoreLift.lhs
+++ b/ghc/compiler/coreSyn/CoreLift.lhs
@@ -4,37 +4,36 @@
 \section[CoreLift]{Lifts unboxed bindings and any references to them}
 
 \begin{code}
-#include "HsVersions.h"
-
 module CoreLift (
        liftCoreBindings,
 
        mkLiftedId,
        liftExpr,
        bindUnlift,
-       applyBindUnlifts,
-       isUnboxedButNotState
+       applyBindUnlifts
 
     ) where
 
-import Ubiq{-uitous-}
+#include "HsVersions.h"
 
 import CoreSyn
 import CoreUtils       ( coreExprType )
 import Id              ( idType, mkSysLocal,
-                         nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..),
-                         GenId{-instances-}
+                         nullIdEnv, growIdEnvList, lookupIdEnv,
+                         mkIdWithNewType,
+                         IdEnv, GenId{-instances-}, Id
                        )
-import PrelInfo                ( liftDataCon, mkLiftTy, statePrimTyCon )
-import TyCon           ( TyCon{-instance-} )
-import Type            ( maybeAppDataTyCon, eqTy )
+import Name            ( isLocallyDefined, getSrcLoc, getOccString )
+import TyCon           ( isBoxedTyCon, TyCon{-instance-} )
+import Type            ( splitAlgTyConApp_maybe )
+import TysPrim         ( statePrimTyCon )
+import TysWiredIn      ( liftDataCon, mkLiftTy )
+import Unique           ( Unique )
 import UniqSupply      ( getUnique, getUniques, splitUniqSupply, UniqSupply )
 import Util            ( zipEqual, zipWithEqual, assertPanic, panic )
 
 infixr 9 `thenL`
 
-updateIdType = panic "CoreLift.updateIdType"
-isBoxedTyCon = panic "CoreLift.isBoxedTyCon"
 \end{code}
 
 %************************************************************************
@@ -81,7 +80,6 @@ liftBindAndScope top_lev bind scopeM
 liftCoreArg :: CoreArg -> LiftM (CoreArg, CoreExpr -> CoreExpr)
 
 liftCoreArg arg@(TyArg     _) = returnL (arg, id)
-liftCoreArg arg@(UsageArg  _) = returnL (arg, id)
 liftCoreArg arg@(LitArg    _) = returnL (arg, id)
 liftCoreArg arg@(VarArg v)
  = isLiftedId v                        `thenL` \ lifted ->
@@ -129,6 +127,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 ->
@@ -209,8 +211,7 @@ liftDeflt (BindDefault binder rhs)
 type LiftM a
   = IdEnv (Id, Id)     -- lifted Ids are mapped to:
                        --   * lifted Id with the same Unique
-                       --     (top-level bindings must keep their
-                       --      unique (see TopLevId in Id.lhs))
+                       --     (top-level bindings must keep their unique
                        --   * unlifted version with a new Unique
     -> UniqSupply      -- unique supply
     -> a               -- result
@@ -257,7 +258,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 ???
 
@@ -275,8 +276,8 @@ mkLiftedId id u
   = ASSERT (isUnboxedButNotState unlifted_ty)
     (lifted_id, unlifted_id)
   where
-    id_name     = getOccurrenceName id
-    lifted_id   = updateIdType id lifted_ty
+    id_name     = _PK_ (getOccString id)               -- yuk!
+    lifted_id   = mkIdWithNewType id lifted_ty
     unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
 
     unlifted_ty = idType id
@@ -285,7 +286,7 @@ mkLiftedId id u
 bindUnlift :: Id -> Id -> CoreExpr -> CoreExpr
 bindUnlift vlift vunlift expr
   = ASSERT (isUnboxedButNotState unlift_ty)
-    ASSERT (lift_ty `eqTy` mkLiftTy unlift_ty)
+    ASSERT (lift_ty == mkLiftTy unlift_ty)
     Case (Var vlift)
           (AlgAlts [(liftDataCon, [vunlift], expr)] NoDefault)
   where
@@ -295,9 +296,9 @@ bindUnlift vlift vunlift expr
 liftExpr :: Id -> CoreExpr -> CoreExpr
 liftExpr vunlift rhs
   = ASSERT (isUnboxedButNotState unlift_ty)
-    ASSERT (rhs_ty `eqTy` unlift_ty)
+    ASSERT (rhs_ty == unlift_ty)
     Case rhs (PrimAlts []
-       (BindDefault vunlift (mkCon liftDataCon [] [unlift_ty] [VarArg vunlift])))
+       (BindDefault vunlift (mkCon liftDataCon [unlift_ty] [VarArg vunlift])))
   where
     rhs_ty    = coreExprType rhs
     unlift_ty = idType vunlift
@@ -307,8 +308,8 @@ applyBindUnlifts :: [CoreExpr -> CoreExpr] -> CoreExpr -> CoreExpr
 applyBindUnlifts []     expr = expr
 applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
 
-isUnboxedButNotState ty
-  = case (maybeAppDataTyCon ty) of
+isUnboxedButNotState ty = 
+    case (splitAlgTyConApp_maybe ty) of
       Nothing -> False
       Just (tycon, _, _) ->
        not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)