Add several new record features

[ghc-hetmet.git] / compiler / ndpFlatten / Flattening.hs

diff --git a/compiler/ndpFlatten/Flattening.hs b/compiler/ndpFlatten/Flattening.hs
index 18daaa6..6072ad6 100644 (file)
--- a/compiler/ndpFlatten/Flattening.hs
+++ b/compiler/ndpFlatten/Flattening.hs
@@ -55,16 +55,16 @@ module Flattening (
 #include "HsVersions.h"
 
 -- friends
 #include "HsVersions.h"
 
 -- friends

-import NDPCoreUtils (tupleTyArgs, funTyArgs, parrElemTy, isDefault,
+import NDPCoreUtils (tupleTyArgs, funTyArgs, isDefault,

                     isLit, mkPArrTy, mkTuple, isSimpleExpr, substIdEnv)
 import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
                     liftVar, liftConst, intersectWithContext, mk'fst,
                     isLit, mkPArrTy, mkTuple, isSimpleExpr, substIdEnv)
 import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
                     liftVar, liftConst, intersectWithContext, mk'fst,

-                    mk'lengthP, mk'replicateP, mk'mapP, mk'bpermuteDftP,
-                    mk'indexOfP,mk'eq,mk'neq) 
+                    mk'mapP, mk'bpermuteDftP, mk'indexOfP,mk'eq,mk'neq) 

 
 -- GHC
 import TcType      ( tcIsForAllTy, tcView )
 import TypeRep     ( Type(..) )
 
 -- GHC
 import TcType      ( tcIsForAllTy, tcView )
 import TypeRep     ( Type(..) )

+import Coercion     ( coercionKind )

 import StaticFlags  (opt_Flatten)
 import Panic        (panic)
 import ErrUtils     (dumpIfSet_dyn)
 import StaticFlags  (opt_Flatten)
 import Panic        (panic)
 import ErrUtils     (dumpIfSet_dyn)

@@ -74,9 +74,9 @@ import Literal      (Literal, literalType)
 import Var         (Var(..), idType, isTyVar)
 import Id          (setIdType)
 import DataCon     (DataCon, dataConTag)
 import Var         (Var(..), idType, isTyVar)
 import Id          (setIdType)
 import DataCon     (DataCon, dataConTag)

-import HscTypes            ( ModGuts(..), ModGuts, HscEnv(..), hscEPS )
+import HscTypes            ( ModGuts(..), HscEnv(..), hscEPS )

 import CoreFVs     (exprFreeVars)
 import CoreFVs     (exprFreeVars)

-import CoreSyn     (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..),
+import CoreSyn     (Expr(..), Bind(..), Alt, AltCon(..),

                     CoreBndr, CoreExpr, CoreBind, mkLams, mkLets,
                     mkApps, mkIntLitInt)  
 import PprCore      (pprCoreExpr)
                     CoreBndr, CoreExpr, CoreBind, mkLams, mkLets,
                     mkApps, mkIntLitInt)  
 import PprCore      (pprCoreExpr)

@@ -91,7 +91,7 @@ import FastString
 
 
 -- FIXME: fro debugging - remove this
 
 
 -- FIXME: fro debugging - remove this

-import TRACE    (trace)
+import Debug.Trace  (trace)

 
 -- standard
 import Monad        (liftM, foldM)
 
 -- standard
 import Monad        (liftM, foldM)

@@ -448,11 +448,12 @@ lift cExpr@(Case expr b _ alts)  =
                 else extendContext [lb] (liftCaseDataCon b alts)
     letWrapper lExpr b lalts
 
                 else extendContext [lb] (liftCaseDataCon b alts)
     letWrapper lExpr b lalts
 

-lift (Note (Coerce t1 t2) expr) =
-  do  
+lift (Cast expr co) =
+  do

     (lexpr, t) <- lift expr
     (lexpr, t) <- lift expr

-    let lt1 = liftTy t1
-    return ((Note (Coerce lt1 (liftTy t2)) lexpr), lt1)
+    let lco = liftTy co
+    let (t1, t2) = coercionKind lco
+    return ((Cast expr lco), t2)

 
 lift (Note note expr) =
   do 
 
 lift (Note note expr) =
   do